使用VBA根据列名将数据从一个Excel表复制到另一个（复杂） [英] Copy data from one excel sheet to another (complex) using VBA based on column name

问题描述

我对VBA非常新鲜，经过5小时的观看视频和谷歌搜索，我认为这只是我的头，任何帮助都非常感谢。

I'm very new to VBA and after 5 hours of watching videos and Googling, I think this is just too over my head... any help is very much appreciated.

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

So I have 2 excel worksheets: Sheet1 and Sheet2. I have a Y/N column in Sheet1 and if the column = "Y" then I want to copy all the data from that row that has a matching column name in 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为null（循环）。结果将是这样的：

So for every time Y/N = Y then copy the data that matches over to sheet2 and do this until sheet1.col1 is null (looping). The result would be this:

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

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

The columns are not in order and are far too numerous to manually input. Then last but not least the Y/N column would need to clear upon finish. I have tried to alter this with no luck:

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

这是为了做一些不同比我想要做的，我不认为我有能力改变这个为我工作。如何做这个？

This was designed to do something different than what I'm trying to do and I don't think I'm capable of changing this to work for me. How wold I do this?

推荐答案

当进一步研究这个问题时，我正在寻找为标题创建一个静态数组... user3561813提供了这个gem（我更改了我的if语句，并循环通过表：

When researching this further I was looking into creating a static array for the headers... then user3561813 provided this gem (I altered it slightly for my if statement and to loop through the sheet:

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

这是非常光滑的，它的工作原理是非常可扩展的。不依赖于具有相同列的两张纸等...我可以看到这在未来非常有用。 ：）

This is pretty slick the way it works and is very scalable. Doesn't depend on both sheets having identical columns etc... I can see this being very useful in the future. :)

这篇关于使用VBA根据列名将数据从一个Excel表复制到另一个（复杂）的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！