[英]Copy data from one excel sheet to another (complex) using VBA based on column name
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. 所以我有2个excel工作表:Sheet1和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中有一个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
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). 因此对于每次Y / N = Y,然后将匹配的数据复制到sheet2并执行此操作,直到sheet1.col1为空(循环)。 The result would be this: 结果将是这样的:
Sheet2
Price Product Date Salesperson
$25 A 1/9/15 John
$15 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. 然后最后但并非最不重要的一点是,Y / N列需要在完成后清除。 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? 我要怎么做?
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 子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$1:$G$3").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
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). 您还可以尝试此操作,前提是各列与上面提到的相同(sheet1中的A到F,sheet2中的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
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. 不依赖于两张纸具有相同的列等。我可以看到这在将来很有用。 :) :)
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.