如何用VBA跨工作簿复制数据并按值分类至新工作表

Here's a complete, refined VBA solution that meets your requirement: copying data from Workbook1 to Workbook2, creating new sheets in Workbook2 whenever the current row's value differs from the previous one, and stopping when a blank row is encountered in Workbook1.

Complete VBA Code #

' Helper function to check if a workbook is already open
Function Is_WorkBook_Open(FileName As String) As Boolean
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(FileName)
    On Error GoTo 0
    Is_WorkBook_Open = Not wb Is Nothing
End Function

Sub icopy()
    Dim c As Long, erow As Long
    Dim shSource As Worksheet, shTarget As Worksheet
    Dim wbSource As Workbook, wbTarget As Workbook
    Dim prevValue As Variant, currValue As Variant
    Dim targetSheetName As String
    
    ' --------------------------
    ' Configure your settings here
    ' --------------------------
    Const SOURCE_SHEET_NAME As String = "Sheet1" ' Name of your source sheet in Workbook1
    Const TARGET_WB_NAME As String = "test.xlsx" ' Name/path of your target workbook
    Const COMPARE_COLUMN As Integer = 1 ' Column to check for value changes (1 = Column A)
    ' --------------------------
    
    ' Set source workbook (assumes this code is in Workbook1; adjust if needed)
    Set wbSource = ThisWorkbook
    Set shSource = wbSource.Worksheets(SOURCE_SHEET_NAME)
    
    ' Open target workbook if not already open
    If Is_WorkBook_Open(TARGET_WB_NAME) Then
        Set wbTarget = Workbooks(TARGET_WB_NAME)
    Else
        ' Replace with full path if target is not in the same directory
        Set wbTarget = Workbooks.Open("C:\Your\Full\Path\To\" & TARGET_WB_NAME)
    End If
    
    ' Start from row 2 (assuming row 1 is header)
    c = 2
    prevValue = shSource.Cells(c, COMPARE_COLUMN).Value
    
    ' Create first target sheet (or use existing if it exists)
    targetSheetName = Trim(prevValue)
    On Error Resume Next
    Set shTarget = wbTarget.Worksheets(targetSheetName)
    On Error GoTo 0
    
    If shTarget Is Nothing Then
        Set shTarget = wbTarget.Worksheets.Add(After:=wbTarget.Worksheets(wbTarget.Worksheets.Count))
        shTarget.Name = targetSheetName
        ' Copy header row to new sheet
        shSource.Rows(1).Copy Destination:=shTarget.Rows(1)
    End If
    erow = 2 ' Next row to paste data in target sheet
    
    ' Loop until blank row is found in source
    Do While shSource.Cells(c, COMPARE_COLUMN).Value <> ""
        currValue = shSource.Cells(c, COMPARE_COLUMN).Value
        
        ' Check if current value differs from previous
        If currValue <> prevValue Then
            ' Create new target sheet for the new value
            targetSheetName = Trim(currValue)
            On Error Resume Next
            Set shTarget = wbTarget.Worksheets(targetSheetName)
            On Error GoTo 0
            
            If shTarget Is Nothing Then
                Set shTarget = wbTarget.Worksheets.Add(After:=wbTarget.Worksheets(wbTarget.Worksheets.Count))
                shTarget.Name = targetSheetName
                shSource.Rows(1).Copy Destination:=shTarget.Rows(1)
            End If
            
            erow = 2 ' Reset paste row for new sheet
            prevValue = currValue ' Update previous value tracker
        End If
        
        ' Copy current row to target sheet
        shSource.Rows(c).Copy Destination:=shTarget.Rows(erow)
        erow = erow + 1
        c = c + 1
    Loop
    
    ' Save changes to target workbook (optional but recommended)
    wbTarget.Save
    
    MsgBox "Data copied successfully!", vbInformation
End Sub

Key Features & Explanations #

• Dynamic Sheet Creation: Automatically creates new sheets in Workbook2 named after the unique values from the compare column. If a sheet with that name already exists, it uses the existing one instead of duplicating.
• Header Consistency: Copies the header row from Workbook1 to every new sheet in Workbook2.
• Blank Row Termination: Stops processing as soon as it hits a blank row in the compare column of Workbook1.
• Error Prevention: Checks if the target workbook is already open to avoid duplicate file opening errors.

Important Notes #

1. Adjust Settings: Modify the constants at the top of the code to match your actual sheet names, target workbook path, and column to check for value changes.
2. Valid Sheet Names: Ensure the values in your compare column don't contain invalid characters (like / \ ? * [ ]) since these can't be used in sheet names.
3. Macro Permissions: Enable macros in Excel when opening your workbooks, as VBA requires this to run.
4. Append vs Overwrite: If you want to append data to existing sheets instead of overwriting, remove the code that resets erow to 2 for existing sheets (adjust the logic to find the last used row in the target sheet instead).

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