使用 VBA 将列复制并粘贴到新工作表

Question

I'm automating a few things for my job to try and create tables from data faster but we have to first take columns from our raw data and paste them to a new sheet as there is extraneous stuff that comes off the instrument. Currently I do it manually as shown below but I want to run a script that automatically pulls columns with: um2,mm2,#, measurement, or treatment in the header. These would be part of a string and the desired column titles would vary minus containing one of the things I just listed. I was thinking of using either InStr to automatically sort through and select the columns or just prompting userinput to select the appropriate ones. I prefer the automated if possible.

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

Was thinking of maybe using this to try and automate it but was unsure how to use the range I want.

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

I have attached an example of the headers, but the number of columns and titles will vary for each data set. Thanks!

Header Examples

credit for above code: https://www.mrexcel.com/board/threads/vba-to-merge-data-from-multiple-sheets-along-with-sheet-name.1171178/

Answer 1

Try something like this:

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

Are you going to be appending data? If not, then this should work and it's pretty close to your code.

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