[英]How to copy "specific" rows from one sheet and paste in to another in an excel using VBA Macros
I have two sheets (sheet 1 and sheet 2).我有两张工作表(工作表 1 和工作表 2)。 Sheet1 is a subset of sheet2.
Sheet1 是 sheet2 的子集。 I have written a macro that compares the headers of two sheets and then if matches, copy all the contents from Sheet 1 to sheet 2. The next requirement is, I have a key column in Sheet1, I now need to paste the contents of sheet 1 to sheet 2, sheet3, sheet 4 based on the key column values.
我写了一个宏来比较两张表的标题,然后如果匹配,将所有内容从表 1 复制到表 2。下一个要求是,我在表 1 中有一个关键列,我现在需要粘贴表的内容1 到工作表 2、工作表 3、工作表 4 基于键列值。 Please find attached the screenshot for details and also please find the code which I have written by taking the help of you guys in the Stack-overflow.
请在附件中找到详细的截图,也请在 Stack-overflow 中找到我在你们的帮助下编写的代码。 I am new to this and need your help.
我是新手,需要你的帮助。 Image.Please Click
图片请点击
Code:代码:
Private Sub CommandButton3_Click()
Application.ScreenUpdating = False
Dim lastrow As Long, header As Range, foundHeader As Range, lCol As Long, srcWS , desWS1 As Worksheet
Set srcWS = Sheets("Sheet1")
Set desWS1 = Sheets("Sheet2")
lastrow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lCol = desWS1.Cells(1, Columns.count).End(xlToLeft).Column
For Each header In desWS1.Range(desWS1.Cells(1, 1), desWS1.Cells(1, lCol))
Set foundHeader = srcWS.Rows(2).Find(header, LookIn:=xlValues, lookat:=xlWhole)
If Not foundHeader Is Nothing Then
srcWS.Range(srcWS.Cells(2, foundHeader.Column), srcWS.Cells(lastrow, foundHeader.Column)).Copy desWS1.Cells(1, header.Column)
End If
Next header
lCol = desWS2.Cells(1, Columns.count).End(xlToLeft).Column
**' I am stuck here. Unable to think beyond these two lines after applying the filter**
**Sheets("Sheet1").Cells(1, 1).AutoFilter Field:=7, Criteria1:="Yellow"
Sheets("Sheet1").Cells(1, 1).SpecialCells(xlCellTypeVisible).Select**
For Each header In desWS2.Range(desWS2.Cells(1, 1), desWS2.Cells(1, lCol))
Set foundHeader = srcWS.Rows(2).Find(header, LookIn:=xlValues, lookat:=xlWhole)
If Not foundHeader Is Nothing Then
srcWS.Range(srcWS.Cells(2, foundHeader.Column), srcWS.Cells(lastrow, foundHeader.Column)).Copy desWS2.Cells(1, header.Column)
End If
Next header
Application.ScreenUpdating = True
End Sub
Many thanks for your time and assistance.非常感谢您的时间和帮助。
Not my work so won't even pretend, but have you tried this?不是我的工作所以甚至不会假装,但你试过这个吗?
Credit: https://www.excelcampus.com/vba/copy-paste-cells-vba-macros/学分: https : //www.excelcampus.com/vba/copy-paste-cells-vba-macros/
Sub Range_Copy_Examples()
'Use the Range.Copy method for a simple copy/paste
'The Range.Copy Method - Copy & Paste with 1 line
Range("A1").Copy Range("C1")
Range("A1:A3").Copy Range("D1:D3")
Range("A1:A3").Copy Range("D1")
'Range.Copy to other worksheets
Worksheets("Sheet1").Range("A1").Copy Worksheets("Sheet2").Range("A1")
'Range.Copy to other workbooks
Workbooks("Book1.xlsx").Worksheets("Sheet1").Range("A1").Copy _
Workbooks("Book2.xlsx").Worksheets("Sheet1").Range("A1")
End Sub
Sub Paste_Values_Examples()
'Set the cells' values equal to another to paste values
'Set a cell's value equal to another cell's value
Range("C1").Value = Range("A1").Value
Range("D1:D3").Value = Range("A1:A3").Value
'Set values between worksheets
Worksheets("Sheet2").Range("A1").Value = Worksheets("Sheet1").Range("A1").Value
'Set values between workbooks
Workbooks("Book2.xlsx").Worksheets("Sheet1").Range("A1").Value = _
Workbooks("Book1.xlsx").Worksheets("Sheet1").Range("A1").Value
End Sub
Essentially you trying to do a vlookup it sounds like.本质上,您尝试进行 vlookup 听起来像。 This site has helped me in the past as well.
这个网站过去也帮助过我。
https://powerspreadsheets.com/excel-vba-vlookup/ https://powerspreadsheets.com/excel-vba-vlookup/
VLookupResult = WorksheetFunction.vlookup(LookupValue, Worksheet.TableArray, ColumnIndex, False)
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.