使用基于列名的 VBA 将数据从一个 Excel 工作表复制到另一个（复杂的）
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/28038263/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Copy data from one excel sheet to another (complex) using VBA based on column name
提问by user3486773
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.
我对 VBA 非常陌生，在观看了 5 个小时的视频和谷歌搜索后，我认为这太过分了……非常感谢任何帮助。
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.
所以我有 2 个 excel 工作表：Sheet1 和 Sheet2。我在 Sheet1 中有一个 Y/N 列，如果该列 = "Y"，那么我想复制该行中在 Sheet2 中具有匹配列名的所有数据。
Sheet1
Product Price SalesPerson Date Commission Y/N
A John 1/9/15 Y
B John 1/12/15 N
B Brad 1/5/15 Y
Sheet2
Price Product Date Salesperson
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:
因此，对于每次 Y/N = Y 然后将匹配的数据复制到 sheet2 并执行此操作直到 sheet1.col1 为空（循环）。结果是这样的：
Sheet2
Price Product Date Salesperson
A 1/9/15 John
B 1/5/15 Brad
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:
这些列没有按顺序排列，而且数量太多而无法手动输入。最后但并非最不重要的是，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
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?
这旨在做一些与我想做的事情不同的事情，我认为我无法改变它来对我来说有效。我该怎么做？
采纳答案by user3486773
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:
在进一步研究时，我正在研究为标题创建一个静态数组......然后 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
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. :)
它的工作方式非常巧妙，并且具有很强的可扩展性。不依赖于具有相同列等的两张工作表......我可以看到这在未来非常有用。:)
回答by Marvin
Alright, now it works also if you have columns in Sheet2 that do not exist in Sheet1.
好的，现在如果 Sheet2 中有 Sheet1 中不存在的列，它也可以工作。
Sub CopySheet() Dim i As Integer Dim LastRow As Integer Dim Search As String Dim Column As Integer
Sub CopySheet() 将 i 变暗为整数 将 LastRow 变暗为整数 将搜索变暗为字符串 将列变暗为整数
Sheets("Sheet1").Activate
Sheets("Sheet1").Range("A1").Select
'Sets an Autofilter to sort out only your Yes rows.
Selection.Autofilter
'Change Field:=5 to the number of the column with your Y/N.
Sheets("Sheet1").Range("$A:$G").Autofilter Field:=7, Criteria1:="Y"
'Finds the last row
LastRow = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, "A").End(xlUp).Row
i = 1
'Change the 3 to the number of columns you got in Sheet2
Do While i <= 3
Search = Sheets("Sheet2").Cells(1, i).Value
Sheets("Sheet1").Activate
'Update the Range to cover all your Columns in Sheet1.
If IsError(Application.Match(Search, Sheets("sheet1").Range("A1:G1"), 0)) Then
'nothing
Else
Column = Application.Match(Search, Sheets("sheet1").Range("A1:G1"), 0)
Sheets("Sheet1").Cells(2, Column).Resize(LastRow, 1).Select
Selection.Copy
Sheets("Sheet2").Activate
Sheets("Sheet2").Cells(2, i).Select
ActiveSheet.Paste
End If
i = i + 1
Loop
'Clear all Y/N = Y
'Update the Range to cover all your Columns in Sheet1.
Sheets("Sheet1").Activate
Column = Application.Match("Y/N", Sheets("sheet1").Range("A1:G1"), 0)
Sheets("Sheet1").Cells(2, Column).Resize(LastRow, 1).Select
Selection.ClearContents
End Sub
回答by dimitris
You can try this also, provided that the columns are as you mentioned above (A to F in sheet1 and A to D in sheet2).
您也可以尝试此操作，前提是列与您上面提到的一样（工作表 1 中的 A 到 F 和工作表 2 中的 A 到 D）。
Sub copies()
Dim i, j, row As Integer
j = Worksheets("sheet1").Range("A1").End(xlDown).row
For i = 1 To j
If Cells(i, 6) = "Y" Then _
row = Worksheets("sheet2").Range("A1").End(xlDown).row + 1
Worksheets("sheet2").Cells(row, 1) = Worksheets("sheet1").Cells(i, 2)
Worksheets("sheet2").Cells(row, 2) = Worksheets("sheet1").Cells(i, 1)
Worksheets("sheet2").Cells(row, 3) = Worksheets("sheet1").Cells(i, 4)
Worksheets("sheet2").Cells(row, 4) = Worksheets("sheet1").Cells(i, 3)
Next
Worksheets("sheet1").Range("F:F").ClearContents
End Sub
