使用VBA根据列名将数据从一个Excel工作表复制到另一个（复杂）工作表

debugcn 发表于 Dev

用户名

我是VBA的新手，看了5个小时的视频和谷歌搜索后，我觉得这太过头了……非常感谢您的帮助。

所以我有2个excel工作表：Sheet1和Sheet2。我在Sheet1中有一个Y / N列，并且如果column =“ Y”，那么我要从Sheet2中具有匹配列名的那一行复制所有数据。

Sheet1
Product     Price     SalesPerson    Date    Commission     Y/N
  A          $25         John       1/9/15      $3           Y 
  B          $20         John       1/12/15     $2           N  
  B          $15         Brad       1/5/15      $1           Y

Sheet2
Price     Product     Date     Salesperson

因此，对于每次Y / N = Y，然后将匹配的数据复制到sheet2并执行此操作，直到sheet1.col1为空（循环）。结果将是这样的：

Sheet2
Price     Product     Date     Salesperson
 $25         A       1/9/15        John
 $15         B       1/5/15        Brad

列不整齐，太多，无法手动输入。然后最后但并非最不重要的一点是，Y / N列需要在完成后清除。我试图改变这一点没有运气：

Sub CopyHeaders()
Dim header As Range, headers As Range
Set headers = Worksheets("Sheet1").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("Sheet2").Cells(2, GetHeaderColumn(header.Value)).End(xlDown).Offset(1, 0)
    End If
Next
End Sub

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

此功能旨在执行与我尝试执行的操作不同的操作，并且我认为我无法更改此设置以适合我的工作。我要怎么做？

用户名

在进行进一步研究时，我正在考虑为标头创建一个静态数组...然后，user3561813提供了该gem（我为if语句稍作改动，并遍历了工作表：

Sub validatetickets()

Do Until ActiveCell.Value = ""
If Cells(ActiveCell.Row, 43) = "Y" Then

Dim wsOrigin As Worksheet
Dim wsDest As Worksheet
Dim nCopyRow As Long
Dim nPasteRow As Long
Dim rngFnd As Range
Dim rngDestSearch As Range
Dim cel As Range

Const ORIGIN_ROW_HEADERS = 1
Const DEST_ROW_HEADERS = 1


Set wsOrigin = Sheets("Case")
Set wsDest = Sheets("Sheet1")

nCopyRow = ActiveCell.Row
nPasteRow = wsDest.Cells(Rows.Count, 1).End(xlUp).Row + 1

Set rngDestSearch = Intersect(wsDest.UsedRange, wsDest.Rows(DEST_ROW_HEADERS))

For Each cel In Intersect(wsOrigin.UsedRange, wsOrigin.Rows(ORIGIN_ROW_HEADERS))
On Error Resume Next
    Set rngFnd = rngDestSearch.Find(cel.Value)

    If rngFnd Is Nothing Then
        'Do Nothing as Header Does not Exist
    Else
        wsDest.Cells(nPasteRow, rngFnd.Column).Value = wsOrigin.Cells(nCopyRow, cel.Column).Value
    End If
On Error GoTo 0

Set rngFnd = Nothing
Next cel
ActiveCell.Offset(1, 0).Select
Else: ActiveCell.Offset(1, 0).Select
End If

Loop
End Sub

它的工作方式十分流畅，并且具有很好的可扩展性。不依赖于两张纸具有相同的列等。我可以看到这在将来很有用。:)

本文收集自互联网，转载请注明来源。

如有侵权，请联系[email protected] 删除。