查找具有特定標題的數據並將整列復制到另一個工作表

Question

我想創建一個 VBA，將我的數據復制到“RAW”中，並通過我的“摘要”表中的特定列排列粘貼到表“摘要”中。

例如，如果工作表“摘要”列 A 是計數器代碼，則從工作表“RAW”中復制數據，該數據位於 B2-B5 中，然后粘貼到我的工作表“摘要”A2-A5 中

我嘗試使用下面的 VBA，它可以工作。 但如果“RAW”中的列數據不同，我將無法獲得正確的數據。

Sub TRANSFERDATA()

Dim LASTROW As Long, EROW As Long
LASTROW = Worksheets("RAW").Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To LASTROW

Worksheets("RAW").Cells(i, 1).Copy

EROW = Worksheets("summary").Cells(Rows.Count, 1).End(xlUp).Row

Worksheets("RAW").Paste Destination:=Worksheets("summary").Cells(EROW + 1, 2)

Worksheets("RAW").Cells(i, 2).Copy

Worksheets("RAW").Paste Destination:=Worksheets("summary").Cells(EROW + 1, 1)

Worksheets("RAW").Cells(i, 3).Copy

Worksheets("RAW").Paste Destination:=Worksheets("summary").Cells(EROW + 1, 4)

Worksheets("RAW").Cells(i, 4).Copy

Worksheets("RAW").Paste Destination:=Worksheets("summary").Cells(EROW + 1, 3)
Next i

End Sub

謝謝！

概括

生的

Answer 1

請測試下一個代碼。 喲不必逐個單元格地復制。 在代碼的設計方式中，它也適用於 header，它與“RAW”工作表中的代碼不同，但包含“RAW”header 字符串：

Sub TestFindCopyInPlace()
   Dim shR As Worksheet, shSum As Worksheet, colHeadR As String
   Dim colHS As Range, lastCol As Long, lastRow As Long, i As Long

   Set shR = Worksheets("RAW")
   Set shSum = Worksheets("summary")
   lastCol = shR.Cells(1, Columns.count).End(xlToLeft).Column
   lastRow = shR.Range("A" & Rows.count).End(xlUp).Row
   For i = 1 To lastCol
        colHeadR = shR.Columns(i).Cells(1, 1).value
        Set colHS = shSum.Rows(1).Find(colHeadR)' find the cell with the header of the one being copied
        If Not colHS Is Nothing Then 'Find method will find a column containing colHeadR in its header string...
             shR.Range(shR.Cells(2, i), shR.Cells(lastRow, i)).Copy Destination:=colHS.Offset(1, 0)
        Else
             MsgBox "The column header """ & colHeadR & """ could not be found." & vbCrLf & _
               "Please check the spelling or whatever you think it is necessary..."
        End If
   Next i
End Sub

該代碼應該適用於您的“RAW”工作表包含的盡可能多的列......

Answer 2

要使該過程完全自動化，請使用以下代碼：

Sub TRANSFERDATA()
    Const rawSheet As String = "RAW"
    Const summarySheet As String = "summary"

    '===================================================================================
    '   Find the last column in both sheets
    '===================================================================================
    Dim rawLastCol As Integer
    Dim summaryLastCol As Integer
    rawLastCol = Worksheets(rawSheet).Cells(1, Columns.Count).End(xlToLeft).Column
    summaryLastCol = Worksheets(summarySheet).Cells(1, Columns.Count).End(xlToLeft).Column

    '===================================================================================
    '   Iterate over all columns in the RAW sheet and transfer data to the summary sheet
    '===================================================================================
    Dim col As Integer
    For col = 1 To rawLastCol

        'Read column header
        Dim header As String
        header = Worksheets(rawSheet).Cells(1, col).Value

        'Find this header in the summary sheet
        Dim col2 As Integer
        For col2 = 1 To summaryLastCol

            If Worksheets(summarySheet).Cells(1, col2).Value = header Then

                'Transfer all values from RAW to the summary sheet
                Dim lastRow As Integer
                lastRow = Worksheets(rawSheet).Cells(Rows.Count, col).End(xlUp).row
                If lastRow > 1 Then 'to handle the case where a column contains no data

                    'First clear previous data
                    Range(Worksheets(summarySheet).Cells(2, col2), Worksheets(summarySheet).Cells(lastRow, col2)).ClearContents

                    'Now, transform data
                    Dim row As Integer
                    For row = 2 To lastRow

                        Worksheets(summarySheet).Cells(row, col2).Value = Worksheets(rawSheet).Cells(row, col).Value
                    Next row
                End If

                'Break
                Exit For
            End If
        Next col2
    Next col

End Sub

如果工作表中的列數或行數發生變化，這將起作用