Question

我想从加载的工作簿中将特定数据复制并粘贴到现有工作表上。

代码一直运行到到达下一行。（请在下面找到完整的代码）

rng.Copy worksheet("WMS").Cells(j, 39)

我猜这有问题 worksheet（“ WMS”）（WMS工作表是现有工作表）包含循环，但没有解决此问题的线索。

您能给我建议我应该尝试什么吗？谢谢。

Private Sub btnMerge_Click()
 
Dim WB As Workbook
Dim WS As Worksheet: Dim toWS As Worksheet

Dim rng As Range
Dim i As Long: i = 0: Dim j As Long
Dim endCol As Long: Dim endRow As Long
Dim strWS As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
If Me.lstWB.ListCount = 0 Then
    MsgBox "No file have selected"
    Exit Sub
End If
 
Set toWS = ActiveSheet
j = toWS.Cells(toWS.Rows.Count, 1).End(xlUp).Row
 
For i = 0 To Me.lstWB.ListCount - 1
    Set WB = Application.Workbooks.Open(Me.lstWB.List(i))
    
    For Each WS In WB.Worksheets
    
            With WS
                endCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
                endRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                Set rng = .Range(.Cells(2, 1), .Cells(2, endRow))
                
                rng.Copy worksheet("WMS").Cells(j, 39)
                j = j + rng.Rows.Count
 
            End With
    Next
    WB.Close
Next
 
MsgBox "Done"
Unload Me
 
Application.ScreenUpdating = True
Application.DisplayAlerts = True
 
End Sub

Answer 1

更改

Set rng = .Range(.Cells(2, 1), .Cells(2, endRow))

到

Set rng = .Range(.Cells(2, 1), .Cells(endRow, endCol))

使用变体数组更有效。 .rows.count与rows.count相同。因为所有工作表的行数都相同。

Private Sub btnMerge_Click()
 
Dim WB As Workbook
Dim WS As Worksheet: Dim toWS As Worksheet

Dim rng As Range
Dim i As Long: i = 0: Dim j As Long
Dim endCol As Long: Dim endRow As Long
Dim strWS As String
Dim Target As Range, vDB As Variant


Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
If Me.lstWB.ListCount = 0 Then
    MsgBox "No file have selected"
    Exit Sub
End If
 
Set toWS = ActiveSheet
'j = toWS.Cells(toWS.Rows.Count, 1).End(xlUp).Row
 
For i = 0 To Me.lstWB.ListCount - 1
    Set WB = Application.Workbooks.Open(Me.lstWB.List(i))
    
    For Each WS In WB.Worksheets
    
            With WS
                endCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
                endRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                'Set rng = .Range(.Cells(2, 1), .Cells(2, endRow))
                vDB = .Range(.Cells(2, 1), .Cells(endRow, endCol))

                'rng.Copy Worksheet("WMS").Cells(j, 39)
                Set Target = toWS.Cells(Rows.Count, 39).End(xlUp)(2)
                'j = j + rng.Rows.Count
                Target.Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB
 
            End With
    Next
    WB.Close
Next
 
MsgBox "Done"
Unload Me
 
Application.ScreenUpdating = True
Application.DisplayAlerts = True
 
End Sub

我想从加载的工作簿中复制特定的数据并将其粘贴到现有工作表上

1 个答案: