使用 VBA 將列復制並粘貼到新工作表

Question

我正在為我的工作自動化一些事情，以嘗試更快地從數據創建表格，但我們必須首先從原始數據中取出列並將它們粘貼到新工作表中，因為儀器會產生無關的東西。 目前我手動執行如下所示，但我想運行一個腳本，自動拉列：um2，mm2，#，測量，或標題中的處理。 這些將是字符串的一部分，所需的列標題會有所不同，減去我剛剛列出的內容之一。 我正在考慮使用 InStr 來自動排序和選擇列，或者只是提示用戶輸入選擇適當的列。 如果可能的話，我更喜歡自動化。

Sub CopyHeaders()
    Dim header As Range, headers As Range
    Set headers = Worksheets("Data").Range("A1:Z1")

    For Each header In headers
        If GetHeaderColumn(header.Value) > 0 Then
            Range(header.offset(1, 0), header.End(xlDown)).Copy Destination:=Worksheets("Raw Data").Cells(2, GetHeaderColumn(header.Value))
        End If
    Next
End Sub

Function GetHeaderColumn(header As String) As Integer
    Dim headers As Range
    Set headers = Worksheets("Raw Data").Range("A1:Z1")
    GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function

正在考慮使用它來嘗試自動化，但不確定如何使用我想要的范圍。

Sub Test()
    Worksheets.FillAcrossSheets Sheet1.[A1:M1]
End Sub

我附上了一個標題示例，但每個數據集的列數和標題數會有所不同。 謝謝！

標題示例

以上代碼的功勞： https : //www.mrexcel.com/board/threads/vba-to-merge-data-from-multiple-sheets-along-with-sheet-name.1171178/

Answer 1

嘗試這樣的事情：

Sub CopyHeaders()
    Dim header As Range, headers As Range, ws As Worksheet, cDest As Range
    
    Set cDest = Worksheets("Copied data").Range("a1") 'first paste destination
    Set ws = Worksheets("Data")
    Set headers = ws.Range("A1:Z1").Cells
    
    For Each header In headers
        If Len(header.Value) > 0 Then
            If CopyThis(header.Value) Then
                ws.Range(header, ws.Cells(ws.Rows.Count, header.Column).End(xlUp)).Copy _
                    cDest
                Set cDest = cDest.Offset(0, 1) 'move one column over
            End If
        End If
    Next
End Sub

'copy this header and data?
Function CopyThis(hdr As String) As Boolean
    Dim v
    For Each v In Array("treatment", "measurement", "um2", "mm2", "#")
        If InStr(1, hdr, v, vbTextCompare) > 0 Then
            CopyThis = True
            Exit For
        End If
    Next v
End Function

Answer 2

你要追加數據嗎？ 如果沒有，那么這應該可以工作，並且與您的代碼非常接近。

Sub CopyHeaders()
    Dim wsData As Worksheet, wsPaste As Worksheet
    Set wsData = Worksheets("Data")
    Set wsPaste = Worksheets("Raw Data")
    
    Dim header As Range, headers As Range
    Set headers = wsData.Range("A1:Z1")
    
    For Each header In headers.Cells
        If IsEmpty(header) Then
        
        'do nothing
        ElseIf testHeaderForMatch(header.Value) Then
            
            If GetHeaderColumn(header.Value) = 0 Then
                Dim lastColumn As Long
                lastColumn = wsPaste.Cells(1, Columns.Count).End(xlToLeft).Column
                wsPaste.Cells(1, lastColumn + 1).Value = header.Value
            End If
                
        wsData.Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=wsPaste.Cells(2, GetHeaderColumn(header.Value))
   
        End If
    Next
End Sub

Function GetHeaderColumn(header As String) As Integer
    Dim headers As Range
    Set headers = Worksheets("Raw Data").Range("A1:Z1")
    GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function

Function testHeaderForMatch(theText As String) As Boolean
Dim theValidMembers As String
    theValidMembers = "um2, mm2, measurement,treatment"
Dim myTextArray() As String
    myTextArray = Split(theValidMembers, ",")

Dim i As Long
For i = LBound(myTextArray) To UBound(myTextArray)
    If theText = myTextArray(i) Then
        testHeaderForMatch = True
        Exit Function
    End If
Next i

End Function