I'm doing some copy-paste
functionality in VBA. I have to copy the entire row if the value in cell A1
matches with the value in the other workbook. Let's say (Sheet name is : Sheet1):
In this sheet, all the values in the cell is the sheet name of the workbook. So from this work book, I have this data (sheet name: conso):
So what I want to do is to find all the values in RangeA
that matches with the Cell values. For example: if Column A
in Sheet1
values matches with the value in Column A
in Conso
, then I have to copy the entire row and paste it in the sheet which is the sheetName
matches with the value in Column A
of Sheet1
. Thanks in advance.
may be I didn't get your exact goal (the title is about copy between workbooks but your explanation doesn't mention different workbooks and deals with different worksheets only) but here comes a "metacode" I think you can follow to reach it
Option Explicit
Sub CopyPaste()
Dim wb1 As Workbook, wb2 As Workbook
Dim shtConso As Worksheet, sht01 As Worksheet, sht As Worksheet
Dim ARng As Range, consoRng As Range, cell As Range
Dim LastRow As Long
Set wb1 = ThisWorkbook '<== set the workbook where "conso" and "Sheet01" sheets are. here I assume the marco will reside in wb1
Set wb2 = Workbooks("wb2") '<== set the workbook where data are to be possibly pasted. it has to be already open at the time this macro runs
Set shtConso = wb1.Worksheets("conso") 'set the "conso" sheet, where there are data to be possibly copied
Set sht01 = wb1.Worksheets("Sheet01") 'set the "Sheet01" sheet, where there are wb2 sheet names
Set ARng = sht01. ... ' set the range in "Sheet01" with wb2 sheets names
Set consoRng = shtConso. ...'set the range in "conso" with wb2 sheets names
For Each cell In ARng 'loop through sheet names to be found in wb2
Set sht = SetSheet(wb2, cell.Value) 'search for wb2 sheet. see the function skeleton below
If Not sht Is Nothing Then ' if found '....
LastRow = GetLastRow(sht, 1) '... get its last non empty row in column A. see the function skeleton below
With consoRng
.AutoFilter .... 'now use .Autofilter method on "consoRng" range to select rows that matches cell.Value
With .SpecialCells(xlCellTypeVisible) ' consider only filtered rows
' check if there are any... maybe using a "Find" method on this filtered range
' ... and if there are, copy the entire row (use .EntireRow property on the filtered range) and paste them to wb2sheet (use wb2 and lastRow variables)
End With
.AutoFilter ' disable autofilter to have the entire range still available
End With
End If
Next
End Sub
Function SetSheet(wb As Workbook, shtName As String) As Worksheet
' write a simple function that that try and set a sheet with the given name in the given workbook
' if it succeed it returns that sheet
' if it fails then it returns "nothing"
End Function
Function GetLastRow(sht As Worksheet, col As Long) As Long
' write a simple function that returns the row of the last non empty cell of the given column in the given worksheet
' use ".End(xlUp)" method of the "Range" object
' handle the cases where either the column has no values or its last non empty cell is in the very last row of that column
End Function
Alot to try an explain in my code, but I believe it does exactly what you asked.
Option Explicit
Sub CopyDataFromOneWorkBookToAnother()
'Setting up Reference to the Data WorkSheet
Dim DataBaseSheet As Worksheet
Set DataBaseSheet = Workbooks("Database WorkBook.xlsx").Sheets("conso")
'Setting up Reference to the OtherWorkBook
Dim SearchCriteriaSheet As Worksheet
Set SearchCriteriaSheet = Workbooks("BookName.xlsm").Sheets("Sheet1")
Dim LastRowSearchCriteria As Long
LastRowSearchCriteria = SearchCriteriaSheet.Cells(SearchCriteriaSheet.Rows.Count, "A").End(xlUp).Row
Dim SearchCriteriaRange As Range
SearchCriteriaSheet.Activate
Set SearchCriteriaRange = SearchCriteriaSheet.Range(Cells(1, "A"), Cells(LastRowSearchCriteria, "A"))
Dim SearchValue As Range
Dim SingleSearchCriteria As String
Dim DataBaseFoundRange As Range
Dim SearchRange As Range
Dim FoundDataRowReference As Range
Dim SingleFoundRange As Range
Dim LastColumInFoundDataRow As Long
Dim PastedRowCounter As Long
Dim LastCellofSearchRange As Range
Dim FirstAddress As String
For Each SearchValue In SearchCriteriaRange
SingleSearchCriteria = SearchValue.Value
DataBaseSheet.Activate
Set SearchRange = DataBaseSheet.Columns("A:A")
'For use in the .Find After:=
'This enables the search to start at the Top of the Column
'Otherwise it skips the initial cell
With SearchRange
Set LastCellofSearchRange = .Cells(.Cells.Count)
End With
Set DataBaseFoundRange = SearchRange.Find(what:=SingleSearchCriteria, After:=LastCellofSearchRange, _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
'To reference the row to paste the data to
PastedRowCounter = 1
'Setting the First Found address in order to know when to quit the Loop
If Not DataBaseFoundRange Is Nothing Then
FirstAddress = DataBaseFoundRange.Address
End If
Do Until DataBaseFoundRange Is Nothing
LastColumInFoundDataRow = DataBaseSheet.Cells(DataBaseFoundRange.Row, Columns.Count).End(xlToLeft).Column
Set SingleFoundRange = DataBaseSheet.Range(Cells(DataBaseFoundRange.Row, "B"), Cells(DataBaseFoundRange.Row, LastColumInFoundDataRow))
SingleFoundRange.Copy
Workbooks("BookName.xlsm").Sheets(DataBaseFoundRange.Value).Cells(PastedRowCounter, "A").PasteSpecial Paste:=xlPasteValues
Set DataBaseFoundRange = SearchRange.FindNext(After:=DataBaseFoundRange)
If DataBaseFoundRange.Address = FirstAddress Then
Exit Do
End If
PastedRowCounter = PastedRowCounter + 1
Loop
Next SearchValue
End Sub
Snap shot of the WorkBook with the search Criteria and this is also the workbook in which the data will be pasted which had the "B1", "B2" , etc sheets.
Snapshot of the "DataBase" workbook with the B1, B2 reference in Column A
Result of the code seen below, where the Data in rows with B1 in Column A are based into Sheet B1 and then sam eiwth B2, etc etc
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.