VBA动态范围循环复制代码求助：跨工作簿复制每周变动数据

Hey there! Since you're new to VBA, let's break down how to fix your initial code and build a solid framework that actually copies your daily sales data to another workbook. Your core idea is on the right track—we just need to iron out the bugs and add the missing pieces to make it work reliably.

First, Let's Spot the Issues in Your Initial Code #

• Typos & Syntax Errors: For X = 1 To LastRowX Step J uses LastRowX (a typo for LastRow) and doesn’t include any actual copy/paste logic to move data.
• Unreliable Last Row Check: Range("A1").End(xlDown).Row stops at the first empty row in column A, which can miss data if there are gaps in your list.
• No Data Transfer: You assign a range to variable V but never use it to copy data to the target workbook.
• Integer Limitation: LastRow As Integer can fail because Excel supports far more rows than the 65,536 limit of Integer—use Long instead for large datasets.
• Incomplete File Path: Workbooks.Open("Filename") needs a full, valid file path to open the source workbook.

Revised Code with Explanations #

Here's a polished version of your script that fixes these issues, adds safeguards, and makes the workflow more user-friendly:

Sub ProdSold()
    Dim sourceWB As Workbook    ' Workbook with your weekly sales data
    Dim targetWB As Workbook    ' Workbook to copy data into
    Dim sourceWS As Worksheet   ' Worksheet holding the source data
    Dim targetWS As Worksheet   ' Worksheet to paste into
    Dim dailySalesCount As Integer ' Number of products sold per day
    Dim lastRow As Long         ' Total rows of data (uses Long for large datasets)
    Dim currentRow As Long      ' Track starting row of current day's data
    Dim pasteRow As Long        ' Track where to paste in the target workbook

    ' 1. Get valid input for daily sales count
    dailySalesCount = InputBox("Please enter the number of products sold per day.")
    If dailySalesCount <= 0 Then
        MsgBox "Oops! Please enter a positive number for daily sales."
        Exit Sub ' Exit if input is invalid
    End If

    ' 2. Set up target workbook/worksheet (this is the workbook running the code)
    Set targetWB = ThisWorkbook
    Set targetWS = targetWB.Sheets("Sheet1") ' Replace with your target sheet name

    ' 3. Let user select the source workbook (avoids hardcoding paths)
    Dim filePicker As FileDialog
    Set filePicker = Application.FileDialog(msoFileDialogFilePicker)
    With filePicker
        .Title = "Select your weekly sales data workbook"
        .Filters.Add "Excel Files", "*.xlsx;*.xlsm" ' Only show Excel files
        If .Show = -1 Then
            Set sourceWB = Workbooks.Open(.SelectedItems(1))
        Else
            MsgBox "No file selected. Exiting script."
            Exit Sub
        End If
    End With
    Set sourceWS = sourceWB.Sheets("Sheet1") ' Replace with your source sheet name

    ' 4. Get the REAL last row of data in column A (ignores empty gaps)
    lastRow = sourceWS.Cells(sourceWS.Rows.Count, "A").End(xlUp).Row

    ' 5. Loop through data and copy daily chunks
    currentRow = 1
    pasteRow = targetWS.Cells(targetWS.Rows.Count, "A").End(xlUp).Row + 1 ' Start pasting after existing data

    Do While currentRow <= lastRow
        ' Define the range to copy (current day's data: A-E columns)
        Dim copyRange As Range
        ' Handle cases where the last day has fewer than dailySalesCount rows
        Dim endRow As Long
        endRow = IIf(currentRow + dailySalesCount - 1 > lastRow, lastRow, currentRow + dailySalesCount - 1)
        Set copyRange = sourceWS.Range("A" & currentRow & ":E" & endRow)

        ' Copy and paste the data
        copyRange.Copy targetWS.Cells(pasteRow, "A")

        ' Move to next day's data and update paste position
        currentRow = endRow + 1
        pasteRow = targetWS.Cells(targetWS.Rows.Count, "A").End(xlUp).Row + 1
    Loop

    ' Clean up: Close source workbook (save changes if needed)
    sourceWB.Close SaveChanges:=False ' Set to True if you need to save edits to the source file
    MsgBox "Daily sales data copied successfully!"
End Sub

Key Improvements to Notice #

• User-Friendly File Selection: Instead of hardcoding a file path, the script lets you pick the source workbook with a dialog box.
• Input Validation: Prevents crashes from invalid entries (like 0 or negative numbers).
• Robust Last Row Detection: Uses Cells(Rows.Count, "A").End(xlUp).Row to find the actual last row of data, even if there are empty cells in column A.
• Flexible Daily Ranges: Handles the last day of the week if it has fewer sales than your input count.
• Avoids Overwriting Data: Pastes new data after existing content in the target workbook instead of starting at row 1.

Bonus: If Your Data is Grouped by Date (Not Fixed Daily Count) #

If your daily sales don't have a fixed number of rows (e.g., some days have 10 sales, others 15), you'll need to group by the date column (assuming column A is dates). Here's a quick snippet to handle that:

' Add this at the top to use dictionaries
Dim dateDict As Object
Set dateDict = CreateObject("Scripting.Dictionary")

' Populate dictionary with unique dates and their row ranges
For currentRow = 1 To lastRow
    Dim saleDate As Date
    saleDate = sourceWS.Cells(currentRow, "A").Value
    If Not dateDict.Exists(saleDate) Then
        dateDict(saleDate) = currentRow
    Else
        dateDict(saleDate) = dateDict(saleDate) & ":" & currentRow
    End If
Next

' Loop through each date and copy its data
For Each key In dateDict.Keys
    Dim dateRange As Range
    Set dateRange = sourceWS.Range("A" & dateDict(key) & ":E" & dateDict(key))
    dateRange.Copy targetWS.Cells(pasteRow, "A")
    pasteRow = targetWS.Cells(targetWS.Rows.Count, "A").End(xlUp).Row + 1
Next

Just replace the loop section in the main code with this if you need date-based grouping.

内容的提问来源于stack exchange，提问作者user9784229