VBA代码改写需求：将逐行复制逻辑改为逐列复制数据

Got it, let's adjust your VBA code to loop through columns instead of rows. I'll fix the core logic, plus clean up some inefficient practices like relying on Activate and Select which often cause bugs.

Modified Code #

Sub Column_copying()
    ' Declare workbook/worksheet objects
    Dim Header As Workbook
    Dim samplelist As Workbook
    Dim wsSample As Worksheet
    Dim wsHeader As Worksheet
    
    ' Open workbooks and assign worksheet references (no more Activate!)
    Set Header = Workbooks.Open("/Users/Header.xlsx")
    Set wsHeader = Header.Sheets("Sheet1") ' Replace with your actual sheet name
    Set samplelist = Workbooks.Open("/Users/samplelist.xlsx")
    Set wsSample = samplelist.Sheets("Sheet1") ' Replace with your actual sheet name
    
    ' Get the last column with data (checks row 1 for the rightmost non-empty cell)
    Dim lastCol As Long
    lastCol = wsSample.Cells(1, wsSample.Columns.Count).End(xlToLeft).Column
    
    ' Loop through each column starting from column 2 (adjust if your data starts at column 1)
    Dim currentCol As Long
    For currentCol = 2 To lastCol
        ' Skip empty columns (checks row 1 for a value; adjust row number if your identifier is elsewhere)
        If wsSample.Cells(1, currentCol).Value <> "" Then
            ' Copy data from samplelist (row 4, current column) to Header's K5:M5
            wsSample.Cells(4, currentCol).Copy Destination:=wsHeader.Range("K5:M5")
            
            ' Copy data from samplelist (row 8, current column) to Header's F5:G5
            wsSample.Cells(8, currentCol).Copy Destination:=wsHeader.Range("F5:G5")
            
            ' Set up save path and filename
            Dim savePath As String, baseName As String, fullFileName As String
            savePath = "/Users/newdata/"
            baseName = "sample_"
            ' Use the identifier from samplelist (row 1, current column) formatted as 3-digit number
            fullFileName = savePath & baseName & Format(wsSample.Cells(1, currentCol).Value, "000") & ".xlsx"
            
            ' Save the Header workbook with the new filename
            Header.SaveAs Filename:=fullFileName
        End If
    Next currentCol
    
    ' Close samplelist without saving changes (change to SaveChanges:=True if needed)
    samplelist.Close SaveChanges:=False
End Sub

Key Changes Explained #

1. Switch from Row to Column Loop

   • Replaced the row loop For lRow = 2 To ... with a column loop For currentCol = 2 To lastCol, using your existing logic to get the last column with data.

2. Adjust Cell References

   • Where you previously referenced cells by row (e.g., Range("D" & lRow)), now we reference by column: Cells(4, currentCol) (this targets row 4 of the current column). Adjust the row number (4, 8) to match where your data lives in samplelist.

3. Remove Activate/Select

   • These methods are slow and prone to errors if your workbook focus changes. Instead, we directly reference worksheets (wsSample, wsHeader) to access cells, and use Destination in the Copy method to paste directly.

4. Fix Filename Logic

   • Your original code had a typo (Range("A") & lRow.Value). Now we use wsSample.Cells(1, currentCol).Value to grab the identifier from the current column (adjust the row number here if your column identifiers are in a different row, like row 2).

Important Notes #

• Match Your Data Structure: Double-check the row numbers in Cells(4, currentCol) and Cells(8, currentCol)—these need to point to the exact rows in samplelist that hold the data you want to copy.
• Specify Sheet Names: Replace "Sheet1" with the actual name of your worksheets in both workbooks to avoid relying on ActiveSheet.
• Adjust Starting Column: If your data starts at column 1 instead of 2, change For currentCol = 2 To lastCol to For currentCol = 1 To lastCol.

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