在最后一行后追加數據

Question

我的宏是將每周報告工作簿中三張工作表中的值附加到累積工作簿中等效工作表中的值。

但是，我無法正確定義 ThisWorkbook.Sheets 中的范圍 - 僅附加 wb.Sheets 中的單元格 A2 值。

有人可以幫我正確定義范圍嗎？ 非常感謝！

Sub Import_SheetData_ThisWorkbook()

Dim lRow As Long, lRow1 As Long, lRow2 As Long, lRow3 As Long
Dim Path As String, WeeklyCollation As String
Dim wkNum As Integer
Dim wb As Workbook

wkNum = Application.InputBox("Enter week number")

Path = "C:\xyz\"
WeeklyCollation = Path & "Activities 2021 w" & wkNum & ".xlsx"

lRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1

Set wb = Workbooks.Open(WeeklyCollation)

lRow1 = wb.Sheets("Customer visits").Cells(Rows.Count, 1).End(xlUp).Row
lRow2 = wb.Sheets("Orders").Cells(Rows.Count, 1).End(xlUp).Row
lRow3 = wb.Sheets("Visits").Cells(Rows.Count, 1).End(xlUp).Row

'Replace with copy and paste
'Can't define range in ThisWorkbook

ThisWorkbook.Sheets("Customer visits").Range("A" & lRow + 1).Value = wb.Sheets("Customer visits").Range("A2:H" & lRow1).Value
ThisWorkbook.Sheets("Orders").Range("A" & lRow + 1).Value = wb.Sheets("Orders").Range("A2:I" & lRow2).Value
ThisWorkbook.Sheets("Visits").Range("A" & lRow + 1).Value = wb.Sheets("Visits").Range("A2:F" & lRow3).Value

wb.Close SaveChanges:=False

MsgBox ("Data added")

End Sub

Answer 1

資料備份

• 調整常量部分中的值。

Option Explicit

Sub ImportSheetData()

    ' Constants
    
    ' Source
    Const sPath As String = "C:\xyz\"
    Const swsNamesList As String = "Customer visits,Orders,Visits"
    Const slrCol As String = "A"
    Const sfRow As Long = 2
    ' Destination
    Const dwsNamesList As String = "Customer visits,Orders,Visits"
    Const dlrCol As String = "A"
    ' Both
    Const Cols As String = "A:H"
    
    ' Create the references to the workbooks.
    
    Dim wkNum As Variant: wkNum = Application.InputBox( _
        "Enter week number", "Import Sheet Data", , , , , , 1)
    If wkNum = False Then
        MsgBox "You canceled.", vbExclamation
        Exit Sub
    End If
    
    Dim sWeeklyCollation As String
    sWeeklyCollation = sPath & "Activities 2021 w" & wkNum & ".xlsx"
    
    Dim swb As Workbook
    On Error Resume Next
        Set swb = Workbooks.Open(sWeeklyCollation)
    On Error GoTo 0
    If swb Is Nothing Then
        MsgBox "Could not find the file '" & sWeeklyCollation & "'.", vbCritical
        Exit Sub
    End If
    
    Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
    
    ' Copy the data.
    
    Dim swsNames() As String: swsNames = Split(swsNamesList, ",")
    Dim dwsNames() As String: dwsNames = Split(dwsNamesList, ",")
    
    Dim sws As Worksheet
    Dim srg As Range
    Dim slRow As Long
    
    Dim dws As Worksheet
    Dim drg As Range
    Dim dCell As Range
    
    Dim n As Long
    Dim rCount As Long
    Dim wsCount As Long ' Counts the number of worksheets processed
    
    For n = 0 To UBound(swsNames)
        On Error Resume Next
            Set sws = swb.Worksheets(swsNames(n))
        On Error GoTo 0
        If Not sws Is Nothing Then ' source worksheet exists
            On Error Resume Next
                Set dws = dwb.Worksheets(dwsNames(n))
            On Error GoTo 0
            If Not dws Is Nothing Then ' destination worksheet exists
                slRow = sws.Cells(sws.Rows.Count, slrCol).End(xlUp).Row
                rCount = slRow - sfRow + 1
                If rCount > 0 Then ' found data in source worksheet
                    Set srg = sws.Columns(Cols).Resize(rCount).Offset(sfRow - 1)
                    Set dCell = dws.Cells(dws.Rows.Count, dlrCol) _
                        .End(xlUp).Offset(1)
                    Set drg = dCell.Resize(rCount).EntireRow.Columns(Cols)
                    drg.Value = srg.Value
                    wsCount = wsCount + 1
                ' Else ' no data in source worksheet
                End If
            'Else ' destination worksheet doesn't exist
            End If
        'Else ' source worksheet doesn't exist
        End If
    Next n
    
    ' Finishing Touches
    
    swb.Close SaveChanges:=False
    'dwb.Save
    ' Or:
    'dwb.Close SaveChanges:=True
    
    MsgBox "Data from " & wsCount & " worksheets added.", vbInformation

End Sub