[英]Macro VBA to Copy Column based on Header and Paste into another Sheet
Background: This is my first time dealing with macros.背景:这是我第一次处理宏。 I will have two worksheets that I'll be using.
我将使用两个工作表。 The first sheet, 'Source' will have data available.
第一个工作表“来源”将提供可用数据。 The second sheet, 'Final' will be blank and is going to be where the macro will be pasting the data I'd like it to collect from the 'Source' sheet.
第二个工作表“最终”将是空白的,并且将是宏将粘贴我希望它从“源”工作表收集的数据的位置。
* I want the macro to find the specified header in the 'Source' sheet, copy that cell containing the header all the way down to the last row of existing data (instead of the entire column), and paste it onto the 'Final' sheet in a specified column (A, B, C, etc.). * 我希望宏在“源”表中找到指定的标题,将包含标题的单元格一直复制到现有数据的最后一行(而不是整列),然后将其粘贴到“最终”指定列(A、B、C 等)中的工作表。 *
*
The reason why I have to specify which headers to find is because the headers in the 'Source' sheet won't always be in the same position, but the 'Final' sheet's headers will always be in the same position – so I CAN'T just record macros copying column A in 'Source' sheet and pasting in column A in 'Final' sheet.我必须指定要查找的标题的原因是因为“源”表中的标题不会始终位于相同位置,但“最终”表的标题将始终位于相同位置 - 所以我可以T 只记录宏复制“源”表中的 A 列并粘贴到“最终”表中的 A 列中。 Also, one day the 'Source' sheet may have 170 rows of data, and another day it may have 180 rows.
此外,有一天“源”表可能有 170 行数据,而另一天可能有 180 行。
Although, it would probably be best to copy the entire column since one of the columns will have a few empty cells rather than to the last row of existing data.尽管如此,最好复制整列,因为其中一列将有几个空单元格,而不是复制到现有数据的最后一行。 I'm assuming it would stop copying when it reaches the first empty cell in the column chosen which would leave out the remaining data after that empty cell in the column – correct me if I'm wrong.
我假设当它到达所选列中的第一个空单元格时它会停止复制,这会在列中的空单元格之后遗漏剩余的数据 - 如果我错了,请纠正我。 If copying the entire column is the best way, then, please provide that as part of the possible solution.
如果复制整个列是最好的方法,那么请将其作为可能的解决方案的一部分提供。 I've attached an example of the before & after result I would like accomplished: Example of Result
我附上了我想要完成的前后结果示例:结果示例
Find Header=X, copy entire column -> Paste into A1 in 'Final' sheet找到 Header=X,复制整列 -> 粘贴到“最终”表中的 A1
Find Header=Y, copy entire column -> Paste into B1 in 'Final' sheet找到 Header=Y,复制整列 -> 粘贴到“最终”表中的 B1
Etc..等等..
I'm sorry if my wording isn't accurate – I tried to explain the best I could.如果我的措辞不准确,我很抱歉——我尽力解释。 It'd be awesome if someone could help me out on this!
如果有人能帮我解决这个问题,那就太棒了! Thanks!
谢谢!
I modified an answer I gave to another user with similar problem for your case, I use dictionary function in most of my data sheets so that I can shift columns around without breaking the code, the below code you can shift your columns around and it will still work我修改了我给另一个有类似问题的用户的答案,我在我的大部分数据表中使用了字典函数,这样我就可以在不破坏代码的情况下移动列,下面的代码可以移动列,它会还在工作
the only main restriction is 1. your header names must be unique 2. your header name of interest must be exactly the same.唯一的主要限制是 1. 您的标题名称必须是唯一的 2. 您感兴趣的标题名称必须完全相同。 ie your source header of interest is PETER then your Data table should have a header with PETER and it must be unique.
即您感兴趣的源头是 PETER,那么您的数据表应该有一个带有 PETER 的头并且它必须是唯一的。
Sub RetrieveData()
Dim wb As Workbook
Dim ws_A As Worksheet
Dim ws_B As Worksheet
Dim HeaderRow_A As Long
Dim HeaderLastColumn_A As Long
Dim TableColStart_A As Long
Dim NameList_A As Object
Dim SourceDataStart As Long
Dim SourceLastRow As Long
Dim Source As Variant
Dim i As Long
Dim ws_B_lastCol As Long
Dim NextEntryline As Long
Dim SourceCol_A As Long
Set wb = ActiveWorkbook
Set ws_A = wb.Worksheets("Sheet A")
Set ws_B = wb.Worksheets("Sheet B")
Set NameList_A = CreateObject("Scripting.Dictionary")
With ws_A
SourceDataStart = 2
HeaderRow_A = 1 'set the header row in sheet A
TableColStart_A = 1 'Set start col in sheet A
HeaderLastColumn_A = .Cells(HeaderRow_A, Columns.Count).End(xlToLeft).Column 'Get number of NAMEs you have
For i = TableColStart_A To HeaderLastColumn_A
If Not NameList_A.Exists(UCase(.Cells(HeaderRow_A, i).Value)) Then 'check if the name exists in the dictionary
NameList_A.Add UCase(.Cells(HeaderRow_A, i).Value), i 'if does not exist record name as KEY and Column number as value in dictionary
End If
Next i
End With
With ws_B 'worksheet you want to paste data into
ws_B_lastCol = .Cells(HeaderRow_A, Columns.Count).End(xlToLeft).Column ' Get number of DATA you have in sheet B
For i = 1 To ws_B_lastCol 'for each data
SourceCol_A = NameList_A(UCase(.Cells(1, i).Value)) 'get the column where the name is in Sheet A from the dictionaary
If SourceCol_A <> 0 Then 'if 0 means the name doesnt exists
SourceLastRow = ws_A.Cells(Rows.Count, SourceCol_A).End(xlUp).Row
Set Source = ws_A.Range(ws_A.Cells(SourceDataStart, SourceCol_A), ws_A.Cells(SourceLastRow, SourceCol_A))
NextEntryline = .Cells(Rows.Count, i).End(xlUp).Row + 1 'get the next entry line of the particular name in sheet A
.Range(.Cells(NextEntryline, i), _
.Cells(NextEntryline, i)) _
.Resize(Source.Rows.Count, Source.Columns.Count).Cells.Value = Source.Cells.Value
End If
Next i
End With
End Sub
u can try with this.你可以试试这个。 i think its clear and step-by-step.
我认为它很清楚,而且是循序渐进的。 it can be very optimized, but to start with vba i think its better this way.
它可以非常优化,但从 vba 开始,我认为这样更好。
the name of the column must be the same in both sheets.两个工作表中的列名称必须相同。
Sub teste()
Dim val
searchText = "TEXT TO SEARCH"
Sheets("sheet1").Select ' origin sheet
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
x = Selection.Columns.Count ' get number of columns
For i = 1 To x 'iterate trough origin columns
val = Cells(1, i).Value
If val = searchText Then
Cells(1, i).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("sheet2").Select ' destination sheet
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
y = Selection.Columns.Count ' get number of columns
For j = 1 To y 'iterate trough destination columns
If Cells(1, j).Value = searchText Then
Cells(1, j).Select
ActiveSheet.Paste
Exit Sub
End If
Next j
End If
Next i
End Sub
good luck祝你好运
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.