I want to create Pivot table at another xlfile, but when I Define Pivot Cache it doesn't work
Can anyone know reason?
Option Explicit
Dim date_sheet As String
Dim csv_sheet As String
Dim ptl_workbook As String
Dim csv_workbook As String
Dim insert_day As String
Sub AOI_PTL_Updater()
Dim rng As Variant
Dim myrng As Range
Dim mypath As String
Dim ptl_last_r As Integer
Dim csv_last_r As Integer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
insert_day = Application.InputBox("ex) 20201217", "Enter the day", Left:=1000, Top:=800, Type:=2)
date_sheet = Right(insert_day, 2)
csv_sheet = InputBox("Ex) 3-1-1", "Enter sepcifitc data name", , 2000, 4000)
mypath = ThisWorkbook.Path & "\" & insert_day & "\"
csv_workbook = Dir(mypath & csv_sheet & ".csv")
ptl_workbook = "AOI_Report.xlsm"
Workbooks.Open Filename:=mypath & csv_workbook
Rows("1:6").Delete Shift:=xlUp
With Columns("B:B")
.Insert Shift:=xlToRight
.Insert Shift:=xlToRight
.Insert Shift:=xlToRight
.Insert Shift:=xlToRight
End With
Range("B1").FormulaR1C1 = "CRD"
Range("C1").FormulaR1C1 = "Pannel"
Range("D1").FormulaR1C1 = "Part_number"
Range("E1").FormulaR1C1 = "Real_NG"
csv_last_r = Cells(Rows.Count, 1).End(xlUp).Row
Set myrng = Range("A2:A" & csv_last_r)
Windows(ptl_workbook).Activate
ptl_last_r = Cells(Rows.Count, "A").End(xlUp).Row
Windows(csv_workbook).Activate
For Each rng In myrng
rng.Offset(0, 1).FormulaR1C1 = "=LEFT(RC[-1],FIND(""["",RC[-1],1)-1)"
rng.Offset(0, 2).FormulaR1C1 = "=MID(RC[-2],FIND(""["",RC[-2],1)+1,FIND(""]"",RC[-2],1)-(LEN(RC[-1])+2))"
rng.Offset(0, 3).FormulaR1C1 = "=INDEX('[" & ptl_workbook & "]PTL_Updater'!R1C3:R" & ptl_last_r & "C3,MATCH(""*""&RC[-2]&""*"",'[" & ptl_workbook & "]PTL_Updater'!R1C10:R" & ptl_last_r & "C10,0))"
rng.Offset(0, 4).FormulaR1C1 = "=AGGREGATE(9,6,RC20:RC28)"
Next
ActiveWorkbook.Save
Call Create_PT
Windows(csv_workbook).Activate
ActiveWindow.Close
Windows(ptl_workbook).Activate
MsgBox ("PTL Update Complete !")
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Create_PT()
'Declare Variables
Dim PSheet As Worksheet
Dim DSheet As Worksheet
Dim PCache As PivotCache
Dim PTable As PivotTable
Dim PRange As Range
Dim LastRow As Long
Dim LastCol As Long
Dim PWorkbook As Workbook
Dim DWorkbook As Workbook
Dim destination_range As String
Dim D_Data As String
'Declare Variables
Windows(ptl_workbook).Activate
Sheets(date_sheet).Select
Set PWorkbook = Workbooks(ptl_workbook)
Set PSheet = PWorkbook.Worksheets(date_sheet)
Set DWorkbook = Workbooks(csv_workbook)
Set DSheet = DWorkbook.Worksheets(csv_sheet)
destination_range = PSheet.Range("B31").Address(ReferenceStyle:=xlR1C1)
'Define Data Range
LastRow = DSheet.Cells(Rows.Count, 1).End(xlUp).Row
LastCol = DSheet.Cells(1, Columns.Count).End(xlToLeft).Column
With DSheet.Cells
D_Data = .Range(.Cells(1, 1), .Cells(LastRow, LastCol)).Address(ReferenceStyle:=xlR1C1)
End With
PWorkbook.Activate
'Define Pivot Cache
Set PCache = PWorkbook.PivotCaches.Create _
(SourceType:=xlDatabase, SourceData:="[" & DWorkbook.Name & "]" & DSheet.Name & "!" & D_Data). _
CreatePivotTable(TableDestination:="[" & PWorkbook.Name & "]" & PSheet.Name & "!" & destination_range, _
TableName:="PTL-data")
Related
I am trying to copy a filtered range from a master dataset to a spreadsheet for each country (loop). I am getting a type mismatch error for Set rng1 = ws2.Range("E2:L" And lRow1) when I set a range in the filtered sheet. Can someone please help me identify the cause of the mismatch?
Sub CopyData_To_TemplateWorkbook2()
Dim wb As Workbook
Dim SavePath, TemplatePath, TemplateFile As String
Dim ws1, ws2, ws3, wbws1, wbws2, wbws3 As Worksheet
Dim rng1, rng2 As Range
Dim MSi As Variant
Dim lRow1, lRow2 As Long
Application.DisplayAlerts = False
'Application.ScreenUpdating = False
TemplatePath = "C:\Users\xyz\Test\"
TemplateFile = "Template_blank.xlsx"
SavePath = "C:\Users\xyz\Test\"
Set ws1 = ThisWorkbook.Sheets("Lists")
Set ws2 = ThisWorkbook.Sheets("Responses 2006 2020")
ws1.Select
For i = 2 To 5 'Loop through list of country names
Set MSi = ws1.Range("A" & i)
ws2.Activate
If ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
ws2.Range("B1").AutoFilter Field:=2, Criteria1:=MSi 'Filter Criteria1 = i
lRow1 = ws2.Range("E" & Rows.Count).End(xlUp).Row
Set rng1 = ws2.Range("E2:L" And lRow1) 'Type mismatch here
'Set rng1 = ws2.Range("E2:L") 'Application-defined or object-defined error here if used
Set wb = Workbooks.Open(Filename:=TemplatePath & "Template_blank.xlsx", Editable:=True)
Set wbws1 = wb.Sheets("Cover sheet")
Set wbws2 = wb.Sheets("Responses")
wbws1.Range("B2").Value = MSi
wbws2.Range("B2").Value = MSi
lRow2 = wbws2.Range("A" & Rows.Count).End(xlUp).Row 'But there is no last row - blank sheet
Set rng2 = wbws2.Range("A6:H") ' And lRow2 ??
rng2.Value = rng1.Value
wb.SaveAs Filename:=SavePath _
& MSi & "_text" & Format(Date, "yyyymmdd") & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
wb.Close SaveChanges:=False
Set rng1 = Nothing
ws1.Select
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
How do I find a value with the Find function?
I want to copy specific data from an external Excel file to the current workbook.
I added Option Explicit to test for errors but it could just spot that I didn't declare the variable. The output is the same.
Sub ReadDataFromCloseFile()
'
' ReadDataFromCloseFile Macro
'
'
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Dim wb As Workbook
Set wb = ThisWorkbook
Dim src As Workbook
' OPEN THE SOURCE EXCEL WORKBOOK IN "READ ONLY MODE".
Set src = Workbooks.Open("C:\test.xlsm", True, True)
Dim masterRow_count As Integer
masterRow_count = wb.Worksheets("Sheet1").Range("A1").End(xlDown).Row
Dim row_number As Integer
row_number = 2
Dim strSearch As String
Dim searchrange As Range
Do
Dim result As Range
strSearch = wb.Worksheets("Sheet1").Range("A" & row_number).Value
Set searchrange = src.Worksheets("Sheet1").Range("D:D")
Set result = searchrange.Find(what:=strSearch, LookIn:=xlValues, lookat:=xlValues)
If Not result Is Nothing Then
'Get the data from Asiamiles
src.Worksheets("Sheet1").Range("AB" & result.Row).Copy wb.Worksheets("Sheet1").Range("B", row_number)
src.Worksheets("Sheet1").Range("J" & result.Row).Copy wb.Worksheets("Sheet1").Range("C", row_number)
src.Worksheets("Sheet1").Range("I" & result.Row).Copy wb.Worksheets("Sheet1").Range("D", row_number)
src.Worksheets("Sheet1").Range("N" & result.Row).Copy wb.Worksheets("Sheet1").Range("E", row_number)
src.Worksheets("Sheet1").Range("AD" & result.Row).Copy wb.Worksheets("Sheet1").Range("F", row_number)
src.Worksheets("Sheet1").Range("P" & result.Row).Copy wb.Worksheets("Sheet1").Range("G", row_number)
src.Worksheets("Sheet1").Range("Q" & result.Row).Copy wb.Worksheets("Sheet1").Range("H", row_number)
End If
row_number = row_number + 1
Loop Until row_number = masterRow_count
src.Close SaveChanges:=False
Set src = Nothing
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
There is another problem .It could not close the Excel workbook. But that is not the largest issue.
LookAt:=xlValues should be LookAt:=xlPart or LookAt:=xlWhole, Range("B", row_number) should be Range("B" & row_number)
Option Explicit
Sub ReadDataFromCloseFile()
Const SRC_WB = "C:\test.xlsm"
Dim wb As Workbook, wbSrc As Workbook
Dim ws As Worksheet, wsSrc As Worksheet
Dim masterRow_count As Long, row_number As Long
Dim rngSearch As Range, rngResult As Range, strSearch As String
Dim i As Long, n As Long, ar, t0 As Single
t0 = Timer
' OPEN THE SOURCE EXCEL WORKBOOK IN "READ ONLY MODE".
Application.ScreenUpdating = False
Set wbSrc = Workbooks.Open(SRC_WB, True, True)
Set wsSrc = wbSrc.Worksheets("Sheet1")
With wsSrc
i = .Cells(.Rows.Count, "D").End(xlUp).Row
Set rngSearch = wsSrc.Range("D1:D" & i)
End With
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1")
ar = Split("AB,J,I,N,AD,P,Q", ",")
With ws
masterRow_count = .Range("A" & .Rows.Count).End(xlUp).Row
For row_number = 2 To masterRow_count
strSearch = .Range("A" & row_number).Value
Set rngResult = rngSearch.Find(what:=strSearch, _
LookIn:=xlValues, lookat:=xlWhole)
If Not rngResult Is Nothing Then
'Get the data from Asiamiles
For i = 0 To UBound(ar)
.Cells(row_number, "B").Offset(0, i) = wsSrc.Cells(rngResult.Row, ar(i))
Next
n = n + 1
End If
Next
End With
wbSrc.Close SaveChanges:=False
Application.ScreenUpdating = True
MsgBox row_number - 1 & " rows scanned, " & _
n & " rows updated", vbInformation, Format(Timer - t0, "0.0 secs")
End Sub
Would like seek help on simplifying down some codes. it worked on some smaller set of data but unable to work on this larger set of around 750rows of data. The aim is to simplify down the data set by the criteria of Banker, and saved each filtered results based on Banker on a new tab, and then save as a separate workbook.
Sub seperate_by_banker()
Dim i, n As Integer
Dim banker As String
i = 2
n = Sheets("Banker").Range("A1").End(xlDown).Row
Do Until i = n
banker = Sheets("Banker").Range("A" & i)
Sheets("ASIA CHINA (PC)").Select
ActiveSheet.Range("$A$1:$Y$1000").AutoFilter Field:=7, Criteria1:= _
banker
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
ActiveSheet.Name = banker
i = i + 1
Loop
Call SplitWorkbook
End Sub
Sub SplitWorkbook()
'Updateby20200806
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim xNWb As Workbook
Dim FolderName As String
Application.ScreenUpdating = False
Set xWb = Application.ThisWorkbook
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = xWb.Path & "\" & xWb.Name & " " & DateString
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
Select Case xWb.FileFormat
Case 51:
FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If Application.ActiveWorkbook.HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56:
FileExtStr = ".xls": FileFormatNum = 56
Case Else:
FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
MkDir FolderName
For Each xWs In xWb.Worksheets
On Error GoTo NErro
If xWs.Visible = xlSheetVisible Then
xWs.Select
xWs.Copy
xFile = FolderName & "\" & xWs.Name & FileExtStr
Set xNWb = Application.Workbooks.Item(Application.Workbooks.Count)
xNWb.SaveAs xFile, FileFormat:=FileFormatNum
xNWb.Close False, xFile
End If
NErro:
xWb.Activate
Next
MsgBox "You can find the files in " & FolderName
Application.ScreenUpdating = True
End Sub
Please, try the next code. It uses array and copy the filtered range after transforming it in an array, so it should be very fast. No need of the second sub, no need of selections, which only consume Excel resources:
Sub seperate_by_banker()
Dim shB As Worksheet, shAC As Worksheet, wbNew As Workbook, lastR As Long, lastRAC As Long
Dim banker As String, rng As Range, rngF As Range, arrB, arr, i As Long, FolderName As String
Set shB = ThisWorkbook.Sheets("Banker")
lastR = shB.Range("A" & shB.rows.count).End(xlUp).row 'last row
arrB = shB.Range("A2:A" & lastR).Value2
Set shAC = ThisWorkbook.Sheets("ASIA CHINA (PC)")
lastRAC = shAC.Range("A" & shAC.rows.count).End(xlUp).row 'last row
FolderName = ThisWorkbook.path & "\" & ThisWorkbook.Name & " " & Format(Now, "yyyy-mm-dd hh-mm-ss")
If Dir(FolderName, vbDirectory) = "" Then MkDir FolderName 'create the folder if it does not exist
For i = 1 To UBound(arrB)
banker = arrB(i, 1)
shAC.AutoFilterMode = False 'eliminate the previous filter, if any
Set rng = shAC.Range("A1:Y" & lastRAC) 'set the range to be processed
rng.AutoFilter field:=6, Criteria1:=banker
Set rngF = rng.SpecialCells(xlCellTypeVisible) 'set a range to keep the filtered cells in the range
arr = arrayFromDiscRange(rngF, False) 'header inclusive
'create the necessary new workbook:
Set wbNew = Workbooks.Add
With wbNew.Sheets(1).Range("A1").Resize(UBound(arr), UBound(arr, 2))
.value = arr
.EntireColumn.AutoFit
End With
wbNew.saveas FolderName & "\" & banker & ".xlsx"
wbNew.Close False
Next i
End Sub
And the necessary function. It transforms the filtered (discontinuous) range in an array and paste it as fast as possible:
Private Function arrayFromDiscRange(rngF As Range, Optional NoHeader As Boolean = False) As Variant
Dim arr, i As Long, j As Long, k As Long, A As Range, R As Range, iRows As Long
'count range rows
For Each A In rngF.Areas
iRows = iRows + A.rows.count
Next A
'Redim the array to keep the range
ReDim arr(1 To iRows - IIf(NoHeader, 1, 0), 1 To rngF.Columns.count): k = 1
For Each A In rngF.Areas 'iterate between the range areas:
For Each R In A.rows 'iterate between the area rows:
If NoHeader And k = 1 Then GoTo Later 'skip the first row, if no header wanted
For j = 1 To R.Columns.count 'iterate between the area row columns:
arr(k, j) = R.cells(1, j).value 'place each row cells value in the array row
Next j
k = k + 1 'increment the array row to receive values
Later:
Next
Next A
arrayFromDiscRange = arr 'returning the created array
End Function
You could create the new workbooks directly from the filtered sheet.
Option Explicit
Sub separate_by_banker()
Dim wb As Workbook, wbNew As Workbook
Dim ws As Worksheet, wsData As Worksheet
Dim rng As Range, arBanker As Variant
Dim n As Long, iLastRow As Long
Dim foldername As String, sName As String
Set wb = ThisWorkbook
Set ws = wb.Sheets("Banker")
iLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
arBanker = ws.Range("A2:A" & iLastRow).Value2
Set wsData = wb.Sheets("ASIA CHINA (PC)")
iLastRow = wsData.Cells(Rows.Count, "A").End(xlUp).Row
Set rng = wsData.Range("A1:Y" & iLastRow)
' make folder for workbooks
foldername = wb.Path & "\" & wb.Name & " " & Format(Now, "yyyy-mm-dd hh-mm-ss")
MkDir foldername
Application.ScreenUpdating = False
For n = 1 To UBound(arBanker)
sName = arBanker(n, 1)
Set wbNew = Workbooks.Add(xlWBATWorksheet) ' 1 sheet
wbNew.Sheets(1).Name = sName
rng.AutoFilter Field:=7, Criteria1:=sName
rng.Copy
wbNew.Sheets(1).Paste
wbNew.Sheets(1).Columns("A:Y").AutoFit
wbNew.SaveAs foldername & "\" & sName & ".xlsx"
wbNew.Close False
Next
wsData.AutoFilterMode = False
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox n-1 & " files created in " & foldername, vbInformation
End Sub
The below code is take the Status of Col"E" If it is = Include then its corresponding sheets ranges will will be converted to PDF.
I have tried at my end but its not working receiving an error invalid procedure call or argument on the line
rng.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=saveLocation
Your help will be appreciated to fix the problem.
Sub SelectSheets_Ranges()
Dim sh As Worksheet, lastR As Long, rng As Range, arr, arrSplit, i As Long, k As Long
Set sh = ActiveSheet
lastR = sh.Range("C" & sh.Rows.Count).End(xlUp).Row
ReDim arr(lastR - 1)
For i = 6 To lastR
If sh.Range("E" & i).Value = "Include" Then
arr(k) = sh.Range("C" & i).Value & "|" & sh.Range("D" & i).Value: k = k + 1
End If
Next i
ReDim Preserve arr(k - 1)
For i = 0 To UBound(arr)
arrSplit = Split(arr(i), "|")
Set rng = Worksheets(arrSplit(0)).Range(arrSplit(1))
'Create and assign variables
Dim saveLocation As String
saveLocation = "C:\Users\marks\OneDrive\Documents\myPDFFile.pdf"
'Save a range as PDF
rng.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=saveLocation
Next
End Sub
Please, try the next code. It saves in ThisWorkbook path, naming the pdf file as "myPDFFile_sheetName.pdf". Each created file will be open in the default pdf application. If it works OK, you can appropriately change the last parameter:
Sub SelectSheets_Ranges_ExpPdf()
Dim sh As Worksheet, lastR As Long, rng As Range, arr, arrSplit, i As Long, k As Long
Set sh = ActiveSheet
lastR = sh.Range("C" & sh.Rows.Count).End(xlUp).Row
ReDim arr(lastR - 1)
For i = 6 To lastR
If sh.Range("E" & i).Value = "Include" Then
arr(k) = sh.Range("C" & i).Value & "|" & sh.Range("D" & i).Value: k = k + 1
End If
Next i
If k > 0 Then
ReDim Preserve arr(k - 1)
Else
MsgBox "No appropriate range (containing ""Include"") could be found...:exit sub"
End If
Dim boolHide As Boolean, boolProt As Boolean
ActiveWorkbook.Unprotect "4321" 'in order to unprotect he workbook structure
For i = 0 To UBound(arr)
boolHide = False: boolProt = False
arrSplit = Split(arr(i), "|")
Set rng = Worksheets(arrSplit(0)).Range(arrSplit(1))
If ActiveWorkbook.Sheets(arrSplit(0)).ProtectContents Then _
ActiveWorkbook.Sheets(arrSplit(0)).Unprotect "4321": boolProt = True
Debug.Print arrSplit(0)
If ActiveWorkbook.Sheets(arrSplit(0)).Visible <> xlSheetVisible Then _
ActiveWorkbook.Sheets(arrSplit(0)).Visible = xlSheetVisible: boolHide = True
'Create and assign variables
Dim saveLocation As String
saveLocation = ThisWorkbook.Path & "\myPDFFile_" & arrSplit(0) & ".pdf"
'Save a range as PDF
rng.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
saveLocation, Quality:=xlQualityStandard, IgnorePrintAreas:=False, OpenAfterPublish:=True
If boolHide Then ActiveWorkbook.Sheets(arrSplit(0)).Visible = xlSheetHidden
If boolProt Then ActiveWorkbook.Sheets(arrSplit(0)).Protect "4321"
Next
ActiveWorkbook.Protect "4321"
End Sub
Try this:
Sub SelectSheets_Ranges()
Dim sh As Worksheet, i As Long
Dim saveLocation As String, FirstSheet As Boolean
saveLocation = "C:\Users\marks\OneDrive\Documents\myPDFFile.pdf"
Set sh = ActiveSheet
FirstSheet = True
For i = 6 To sh.Range("C" & sh.Rows.Count).End(xlUp).Row
If sh.Cells(i, "E") = "Include" Then
'FirstSheet determines whether the sheet is added to currently-selected
' sheets or not (if not then it replaces them)
ThisWorkbook.Sheets(sh.Cells(i, "C").Value).Select FirstSheet
FirstSheet = False
End If
Next i
If Not FirstSheet Then
'at least one sheet was included
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=saveLocation
End If
End Sub
I assume you want all the ranges from the different sheets in one pdf.
Option Explicit
Sub SelectSheets_Ranges()
Const FOLDER = "C:\Users\marks\OneDrive\Documents\"
Const FILENAME = "myPDFFile.pdf"
Dim wb As Workbook, wbPDF As Workbook
Dim sh As Worksheet, wsPDF As Worksheet
Dim lastR As Long, rng As Range, r As Long, n As Integer, m As Integer
Set sh = ActiveSheet
Set wb = ActiveWorkbook
lastR = sh.Range("C" & sh.Rows.Count).End(xlUp).Row
' create temp workbook to hold ranges
Set wbPDF = Workbooks.Add
m = wbPDF.Sheets.Count
n = m
With sh
For r = 6 To lastR
If .Cells(r, "E").Value = "Include" Then
Set rng = wb.Sheets(.Cells(r, "C").Value).Range(.Cells(r, "D").Value)
Set wsPDF = wbPDF.Sheets.Add(After:=wbPDF.Sheets(n))
rng.Copy wsPDF.Range("A1")
n = n + 1
End If
Next
End With
' delete initial sheets
Application.DisplayAlerts = False
For n = m To 1 Step -1
wbPDF.Sheets(n).Delete
Next
Application.DisplayAlerts = True
'end
wbPDF.ExportAsFixedFormat Type:=xlTypePDF, FILENAME:=FOLDER & FILENAME
'wbPDF.SaveAs FOLDER & "debug.xlsx"
wbPDF.Close False
MsgBox "PDF created " & FOLDER & FILENAME, vbInformation
End Sub
The below code copies from one file to another.
I only want TO ADD the word "AVA" to cells in the Column H but only until the last row.
So basically the macro filters on "PENDING" and I have 14 rows of Pending data , then all the 14 cells of Column H should be showing "AVA".
Any recommendations?
Sub DS()
Dim sourceWorkbook As Workbook
Dim targetWorkbook As Workbook
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim sourceWorkbookPath As String
Dim targetWorkbookPath As String
Dim lastRow As Long
Dim i As Long
' Define workbooks paths
sourceWorkbookPath = "H:\Roy\Transfers Project\ Transfers 2020 - Roy.xlsm"
targetWorkbookPath = "H:\Roy\ 2020\SAP - ZPSD02_template2.xlsx"
' Set a reference to the target Workbook and sheets
Set sourceWorkbook = Workbooks.Open(sourceWorkbookPath)
Set targetWorkbook = Workbooks.Open(targetWorkbookPath)
' definr worksheet's names for each workbook
Set sourceSheet = sourceWorkbook.Worksheets("S TO S")
Set targetSheet = targetWorkbook.Worksheets("Sheet1")
Application.ScreenUpdating = False
With sourceSheet
' Get last row
lastRow = .Range("J" & .Rows.Count).End(xlUp).Row
For i = 1 To lastRow
.Range("H" & i).Value = "AVA" & .Range("H" & i).Value
Next i
.Range("A1:O1").AutoFilter Field:=12, Criteria1:="PENDING"
.Range("A1:O1").AutoFilter Field:=10, Criteria1:="U3R", Operator:=xlOr, Criteria2:="U2R"
.Range("J2:J" & lastRow).SpecialCells(xlCellTypeVisible).Copy _
Destination:=targetSheet.Range("A1")
.Range("C2:C" & lastRow).SpecialCells(xlCellTypeVisible).Copy _
Destination:=targetSheet.Range("B1")
.Range("D2:D" & lastRow).SpecialCells(xlCellTypeVisible).Copy _
Destination:=targetSheet.Range("E1")
.Range("H2:H" & lastRow).SpecialCells(xlCellTypeVisible).Copy _
Destination:=targetSheet.Range("F1")
End With
With targetSheet
For i = 1 To lastRow
.Range("H" & i).Value = "AVA"
Next i
End With
Application.ScreenUpdating = True
End Sub
Sub DS()
Dim sourceWorkbook As Workbook
Dim targetWorkbook As Workbook
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim sourceWorkbookPath As String
Dim targetWorkbookPath As String
Dim lastRow As Long
Dim i As Long
Application.ScreenUpdating = False
' Define workbooks paths
sourceWorkbookPath = "H:\Roy\Transfers Project\ Transfers 2020 - Roy.xlsm"
targetWorkbookPath = "H:\Roy\ 2020\SAP - ZPSD02_template2.xlsx"
' Set a reference to the target Workbook and sheets
Set sourceWorkbook = Workbooks.Open(sourceWorkbookPath)
Set targetWorkbook = Workbooks.Open(targetWorkbookPath)
' Define worksheet's names for each workbook
Set sourceSheet = sourceWorkbook.Worksheets("S TO S")
Set targetSheet = targetWorkbook.Worksheets("Sheet1")
With sourceSheet
' Get last row
lastRow = .Range("J" & .Rows.Count).End(xlUp).Row
.Range("A1:O1").AutoFilter Field:=12, Criteria1:="PENDING"
.Range("A1:O1").AutoFilter Field:=10, Criteria1:="U3R", Operator:=xlOr, Criteria2:="U2R"
.Range("J2:J" & lastRow).SpecialCells(xlCellTypeVisible).Copy Destination:=targetSheet.Range("A1")
.Range("C2:C" & lastRow).SpecialCells(xlCellTypeVisible).Copy Destination:=targetSheet.Range("B1")
.Range("D2:D" & lastRow).SpecialCells(xlCellTypeVisible).Copy Destination:=targetSheet.Range("E1")
.Range("H2:H" & lastRow).SpecialCells(xlCellTypeVisible).Copy Destination:=targetSheet.Range("F1")
End With
With targetSheet
For i = 1 To lastRow
.Range("H" & i).Value = "AVA"
Next i
End With
Application.ScreenUpdating = True
End Sub