用于Excel的VB问题 [英] VB question for Excel
问题描述
您好，
我正在将一些电子表格合并到一个摘要表中，但我不想复制数据（来自多个工作表）开始直到行/列D9，我不希望它在摘要表上开始粘贴，直到D9。这是我当前的代码...如何在其他指令中添加
？
功能LastRow（sh作为工作表）
  On Error Resume Next
LastRow = sh.Cells.Find（What：=" *"，_
               后：= sh.Range（QUOT; A1"），_
    LOOKAT：= xlPart，_
                LookIn：= xlFormulas，_
$
SearchOrder：= xlByRows，_
   & NBSP;  SearchDirection：= xlPrevious，_
          MatchCase：= False）.Row
On Error GoTo 0
结束功能
功能LastCol（sh作为工作表）
; On Error Resume Next
LastCol = sh.Cells.Find（What：=" *"，_
               后：= sh.Range（QUOT; A1"），_
    LOOKAT：= xlPart，_
                LookIn：= xlFormulas，_
$
SearchOrder：= xlByColumns，_
  &NBS磷;   SearchDirection：= xlPrevious，_
          MatchCase：= False）.Column
On Error GoTo 0
结束功能
Sub CopyDataWithoutHeaders（" A1"：" A8"）
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long
应用程序
.ScreenUpdating = False
.EnableEvents = False
结束用$
'删除摘要表（如果存在）。
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets（"综合"）。删除
On Error GoTo 0
Application.DisplayAlerts = True
'添加新的摘要工作表。
设置DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name =" Comprehensive" $
'填写起始行。
StartRow = 2
'遍历所有工作表并将数据复制到
'摘要工作表。
For Each sh In ActiveWorkbook.Worksheets
如果sh.Name<> DestSh.Name然后
'查找包含摘要数据的最后一行
'和来源工作表。
Last = LastRow（DestSh）
shLast = LastRow（sh）
'如果来源工作表不是空的，那么最后一个是
'row> = StartRow，复制范围。
如果shLast> 0和shLast> = StartRow然后是
'设置您要复制的范围
设置CopyRng = sh.Range（sh.Rows（StartRow），sh.Rows（shLast））
;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP; '测试以查看摘要中是否有足够的行
'工作表复制所有数据。
如果Last + CopyRng.Rows.Count> DestSh.Rows.Count然后
&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP; MsgBox""中没有足够的行" &安培; _
"总结工作表以将数据"
&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP;&NBSP ;&NBSP;&NBSP; GoTo ExitTheSub
结束如果
'此声明复制值和格式。
CopyRng.Copy
使用DestSh.Cells（最后+1，" A"）
&NBSP;&NBSP;&NBSP;&NBSP;&NBSP; .PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
结束与$
结束如果
结束如果是
下一页
退出TheSub：
Application.Goto DestSh.Cells（1）
'在摘要表中自动调整列宽。
DestSh.Columns.AutoFit
应用程序
.ScreenUpdating = True
.EnableEvents = True
结束用$
结束子
$
谢谢你，莫妮卡
您好monica crw，
您是否要将数据从E10复制到最后并粘贴到E10的摘要表中？这是我修改过的代码。
Sub CopyDataWithoutHeaders（）
Dim sh As Worksheet
Dim DestSh As工作表
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow With Long
申请
.ScreenUpdating = False
.EnableEvents = False
结束时
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets（" Comprehensive"）。删除
On Error GoTo 0
Application.DisplayAlerts = True
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name =" Comprehensive"
For Each sh In ActiveWorkbook.Worksheets
如果sh.Name<> DestSh.Name然后
Last = LastRow（DestSh）
如果Last< 10然后Last = 10'从第10行开始粘贴
shLast = LastRow（sh）
'确认从E10开始有价值
如果shLast> 9和LastCol（sh）> 4然后
设置CopyRng = sh.Range（" E10"，sh.Cells.SpecialCells（xlCellTypeLastCell））
如果Last + CopyRng.Rows.Count> DestSh.Rows.Count然后
MsgBox""行中没有足够的行" &安培; _
"用于放置数据的摘要工作表。"
GoTo ExitTheSub
End if
CopyRng.Copy
使用DestSh.Cells（Last + 1，" E"）
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
以$ b结尾
$ b结束如果
结束如果
下一个
退出TheSub：
Application.Goto DestSh。单元格（1）
DestSh.Columns.AutoFit
使用应用程序
.ScreenUpdating = True
.EnableEvents =真
结束
结束子最好的问候，
特里
Hello,
I am merging some spreadsheets into one summary sheet, but I do not want the data copied (from the multiple sheets) to start until row/column D9 and I do not want it to start the paste on the summary sheet until D9. Here is my current code... How do I add the other directives?
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Sub CopyDataWithoutHeaders("A1":"A8")
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
' Delete the summary sheet if it exists.
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Comprehensive").Delete
On Error GoTo 0
Application.DisplayAlerts = True
' Add a new summary worksheet.
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Comprehensive"
' Fill in the start row.
StartRow = 2
' Loop through all worksheets and copy the data to the
' summary worksheet.
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
' Find the last row with data on the summary
' and source worksheets.
Last = LastRow(DestSh)
shLast = LastRow(sh)
' If source worksheet is not empty and if the last
' row >= StartRow, copy the range.
If shLast > 0 And shLast >= StartRow Then
'Set the range that you want to copy
Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
' Test to see whether there are enough rows in the summary
' worksheet to copy all the data.
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the " & _
"summary worksheet to place the data."
GoTo ExitTheSub
End If
' This statement copies values and formats.
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
' AutoFit the column width in the summary sheet.
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Thank you, Monica
Hi monica crw,
Do you want to copy data from E10 to the end and also paste on the summary sheet from E10? Here is the code I modified.
Sub CopyDataWithoutHeaders() Dim sh As Worksheet Dim DestSh As Worksheet Dim Last As Long Dim shLast As Long Dim CopyRng As Range Dim StartRow As Long With Application .ScreenUpdating = False .EnableEvents = False End With Application.DisplayAlerts = False On Error Resume Next ActiveWorkbook.Worksheets("Comprehensive").Delete On Error GoTo 0 Application.DisplayAlerts = True Set DestSh = ActiveWorkbook.Worksheets.Add DestSh.Name = "Comprehensive" For Each sh In ActiveWorkbook.Worksheets If sh.Name <> DestSh.Name Then Last = LastRow(DestSh) If Last < 10 Then Last = 10 'paste on start from row 10 shLast = LastRow(sh) 'confirm there is value starts from E10 If shLast > 9 And LastCol(sh) > 4 Then Set CopyRng = sh.Range("E10", sh.Cells.SpecialCells(xlCellTypeLastCell)) If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then MsgBox "There are not enough rows in the " & _ "summary worksheet to place the data." GoTo ExitTheSub End If CopyRng.Copy With DestSh.Cells(Last + 1, "E") .PasteSpecial xlPasteValues .PasteSpecial xlPasteFormats Application.CutCopyMode = False End With End If End If Next ExitTheSub: Application.Goto DestSh.Cells(1) DestSh.Columns.AutoFit With Application .ScreenUpdating = True .EnableEvents = True End With End SubBest Regards,
Terry
这篇关于用于Excel的VB问题的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
