使用 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