VB脚本开发求助：实现Excel指定内容跨工作簿复制整理

Hey there! I get that you're new to VB macros and need to expand your existing script to split the Excel file into two sheets with specific content. Let's fix that up for you. Here's a complete macro that does exactly what you need, plus I'll break down each part so you understand what's going on:

Sub convertJ3ToPhase1()
    ' Get source file from user
    Dim sourceFilePath As Variant
    sourceFilePath = Application.GetOpenFilename( _
        FileFilter:="Excel Workbooks (*.xls*),*.xls*", _
        Title:="Open Database File")
    
    ' Exit if user cancels file picker
    If sourceFilePath = False Then Exit Sub
    
    ' Define destination path and ensure folder exists
    Dim destFolder As String
    Dim destFilePath As String
    destFolder = "C:\Test\"
    destFilePath = destFolder & "ABC.xlsx"
    
    ' Create destination folder if it doesn't exist
    If Dir(destFolder, vbDirectory) = "" Then
        MkDir destFolder
    End If
    
    ' Declare workbook/sheet objects
    Dim sourceWB As Workbook
    Dim newWB As Workbook
    Dim headerSheet As Worksheet
    Dim detailsSheet As Worksheet
    
    ' Open source workbook invisibly
    Application.ScreenUpdating = False
    Set sourceWB = Workbooks.Open(sourceFilePath, ReadOnly:=True)
    
    ' Create new workbook and set up sheets
    Set newWB = Workbooks.Add(xlWBATWorksheet) ' Start with one sheet
    Set headerSheet = newWB.Sheets(1)
    headerSheet.Name = "Header Sheet"
    Set detailsSheet = newWB.Sheets.Add(After:=headerSheet)
    detailsSheet.Name = "Details Sheet"
    
    ' Copy first 9 rows from source to Header Sheet
    sourceWB.Sheets(1).Rows("1:9").Copy Destination:=headerSheet.Range("A1")
    
    ' Define which columns to extract (adjust these numbers to match your needs!)
    ' Example: Array(1,3,5) means columns A, C, E
    Dim columnsToExtract As Variant
    columnsToExtract = Array(1, 2, 4, 5, 7, 9, 10, 12, 15, 19) ' Replace with your 10 column indices
    
    ' Copy specified columns from row 10 onwards to Details Sheet
    Dim lastRow As Long
    lastRow = sourceWB.Sheets(1).Cells(sourceWB.Sheets(1).Rows.Count, "A").End(xlUp).Row
    
    ' Loop through each column to extract and copy
    Dim colIndex As Variant
    Dim destCol As Integer
    destCol = 1
    For Each colIndex In columnsToExtract
        sourceWB.Sheets(1).Columns(colIndex).Rows("10:" & lastRow).Copy _
            Destination:=detailsSheet.Cells(1, destCol)
        destCol = destCol + 1
    Next colIndex
    
    ' Save the new workbook
    newWB.SaveAs Filename:=destFilePath, FileFormat:=xlOpenXMLWorkbook
    
    ' Clean up: close files and release objects
    sourceWB.Close SaveChanges:=False
    newWB.Close SaveChanges:=False
    Application.ScreenUpdating = True
    
    Set sourceWB = Nothing
    Set newWB = Nothing
    Set headerSheet = Nothing
    Set detailsSheet = Nothing
    
    MsgBox "Conversion complete! File saved to: " & destFilePath, vbInformation
End Sub

Key Notes for You: #

• Column Adjustment: The columnsToExtract array uses column numbers (1 = A, 2 = B, etc.). Make sure you replace the example values with the actual 10 columns you need from your source file.
• Invisible Processing: The macro turns off ScreenUpdating so the user doesn't see the source workbook open/close, making it smoother.
• Folder Creation: If C:\Test doesn't exist, the macro will create it automatically to avoid save errors.
• Error Prevention: The script checks if the user cancels the file picker, so it won't crash if they back out.

Just paste this into your VBA editor (Alt+F11), adjust the column indices in columnsToExtract, and test it out! Let me know if you need help tweaking anything specific.

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