Harshil Mehta
Board Regular
- Joined
- May 14, 2020
- Messages
- 85
- Office Version
- 2013
- Platform
- Windows
I have 4 sheets in total in another workbook. I want my code to copy range if the criteria is met in sheet1 of another workbook and if not, then don't copy and move to sheet2, 3 & 4 (if criteria not met don't copy and move to next sheet for all the sheets) and paste data in this workbook sheets(Temp.Sheet). Range.A7 (Headers) one below the other.
The below code seems to copy the entire sheet when the criteria is not met and overwrites the data in the destination.
Could someone please help me figure this out?
The below code seems to copy the entire sheet when the criteria is not met and overwrites the data in the destination.
Could someone please help me figure this out?
VBA Code:
Sub Import_Data1()
Dim FileToOpen As Variant
Dim OpenBook As Workbook
Dim lcol, lrow, lrc As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
For Each ws In Worksheets
ws.Calculate
Next ws
FileToOpen = Application.GetOpenFilename(Title:="Browse for your file & import range", Filefilter:="Excel Files(.xls),xls")
If FileToOpen <> False Then
ThisWorkbook.Worksheets(10).Range(Cells(1, 9), Cells(Rows.Count, Columns.Count)).EntireColumn.Delete
lrc = ThisWorkbook.Worksheets(10).Range("C:C").SpecialCells(xlCellTypeLastCell).Row
ThisWorkbook.Worksheets("Temp.Sheet").Cells.Clear
Set OpenBook = Application.Workbooks.Open(FileToOpen)
With OpenBook.Worksheets(1)
lcol = .Cells(7, .Columns.Count).End(xlToLeft).Column
lrow = .Cells(Rows.Count, 1).End(xlUp).Row
.Range(.Cells(7, 1), .Cells(lrow, lcol)).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=ThisWorkbook.Worksheets(10).Range("C25:G" & lrc), Copytorange:=ThisWorkbook.Worksheets("Temp.Sheet").Range("A7"), Unique:=False
End With
With OpenBook.Worksheets(2)
lr = ThisWorkbook.Worksheets("Temp.Sheet").Cells(Rows.Count, 1).End(xlUp).Row
lcol = .Cells(7, .Columns.Count).End(xlToLeft).Column
lrow = .Cells(Rows.Count, 1).End(xlUp).Row
.Range(.Cells(7, 1), .Cells(lrow, lcol)).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=ThisWorkbook.Worksheets(10).Range("C25:G" & lrc), Copytorange:=ThisWorkbook.Worksheets("Temp.Sheet").Range("A7" & lr + 1), Unique:=False
End With
With OpenBook.Worksheets(3)
lr = ThisWorkbook.Worksheets("Temp.Sheet").Cells(Rows.Count, 1).End(xlUp).Row
lcol = .Cells(7, .Columns.Count).End(xlToLeft).Column
lrow = .Cells(Rows.Count, 1).End(xlUp).Row
.Range(.Cells(7, 1), .Cells(lrow, lcol)).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=ThisWorkbook.Worksheets(10).Range("C25:G" & lrc), Copytorange:=ThisWorkbook.Worksheets("Temp.Sheet").Range("A7" & lr + 1), Unique:=False
End With
With OpenBook.Worksheets(4)
lr = ThisWorkbook.Worksheets("Temp.Sheet").Cells(Rows.Count, 1).End(xlUp).Row
lcol = .Cells(7, .Columns.Count).End(xlToLeft).Column
lrow = .Cells(Rows.Count, 1).End(xlUp).Row
.Range(.Cells(7, 1), .Cells(lrow, lcol)).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=ThisWorkbook.Worksheets(10).Range("C25:G" & lrc), Copytorange:=ThisWorkbook.Worksheets("Temp.Sheet").Range("A7" & lr + 1), Unique:=False
End With
OpenBook.Close False
Else
Exit Sub
End If
If WorksheetFunction.CountA(Sheets("Temp.Sheet").Range("A8:XFD18")) = 0 Then
Sheet10.Range(Cells(1, 9), Cells(Rows.Count, Columns.Count)).EntireColumn.Delete
MsgBox ("No data found as per the criteria.")
Exit Sub
End If
End Sub