I have code like that:
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long
Dim LastRow As Long
Set wsCopy = Workbooks("file1.xlsm").Worksheets("Order")
Set wsDest = Workbooks("orders.xlsm").Worksheets("All Data")
lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(0).Row
wsCopy.Range("A1:I9" & lCopyLastRow).Copy _
wsDest.Range("A" & lDestLastRow)
LastRow = Sheets("All Data").UsedRange.Rows.Count
Sheets("All Data").Range("L" & lDestLastRow).Value = "order made?:"
Sheets("All Data").Range("L" & lDestLastRow + 1).Value = "Yes/No"
Range("L" & lDestLastRow).Font.Bold = True
wsDest.Activate
In place where i have Workbooks("file1.xlsm") i want pick file to copy.
It is possible using Workbooks or any other method?
With the GetOpenFilename-method, Workbooks.Open and replacing your string with the variable:
Dim selectedFilename As Variant
selectedFilename = Application.GetOpenFilename(FileFilter:=”Excel Files,*.xl*;*.xm*”)
If selectedFilename <> False Then
Workbooks.Open FileName:=selectedFilename
End If
Set wsCopy = Workbooks(Mid$(selectedFilename, InStrRev(selectedFilename, "\") + 1)).Worksheets("Order")
Related
I am trying to copy data from multiple worksheets to another workbook using a loop.
The code breaks when it gets to
Set wsCopy = Workbooks("acex_resultsv1.xlsm").Worksheets(i)
Public Sub Update_Dashboard()
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long
Dim i As Integer
i = 1
Do While i <= Worksheets.Count
Worksheets(i).Select
Set wsCopy = Workbooks("acex_resultsv1.xlsm").Worksheets(i)
Set wsDest = Workbooks("acex_results.xlsm").Worksheets(i + 1)
lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
wsDest.Range("A2:BI" & lDestLastRow).ClearContents
wsCopy.Range("A2:BI" & lCopyLastRow).Copy _
wsDest.Range("A2")
ActiveCell.Offset(1, 0).Select
i = i + 1
Loop
Worksheets("Dashboard").Select
End Sub
Untested:
Public Sub Update_Dashboard()
Dim wbCopy As Workbook, wsCopy As Worksheet
Dim wbDest As Workbook, wsDest As Worksheet
Dim lCopyLastRow As Long, lDestLastRow As Long, i As Long
Set wbCopy = Workbooks("acex_resultsv1.xlsm")
Set wbDest = Workbooks("acex_results.xlsm") 'ThisWorkbook?
For i = 1 To wbCopy.Worksheets.Count
Set wsCopy = wbCopy.Worksheets(i)
Set wsDest = wbDest.Worksheets(i + 1)
lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).row
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).row
wsDest.Range("A2:BI" & lDestLastRow).ClearContents
wsCopy.Range("A2:BI" & lCopyLastRow).Copy wsDest.Range("A2")
Next i
wbDest.Worksheets("Dashboard").Select
End Sub
I'm with Tim. Declare variables for source and destination workbooks, Worksheets.Count should be the count worksheets in wbSource.
Also note there is no reason to .Select anything in this process. It only hogs memory.
I need to copy data from multiple worksheets and consolidate them into my master file. My code works fine when there is data in the worrksheets. However, when there is no data on the worksheet, the copied data will be my headers instead. Could anyone help me to write a code into my existing code where no data will be copied if the worksheet has no data? Thank you so much
Dim wsCopy As Worksheet
Dim wsDest As Worksheet
Dim lCopyLastRow As Long
Dim lDestLastRow As Long
Sheets("SEA-Weekly New Opp").Select
Range("A4:N1000").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Workbooks.Open "Z:\SFDC Reporting\MSIA(PENANG,ESTEROL,TAMPOI) Reporting Template.xlsm",
Password:="Mingsee"
Set wsCopy = Workbooks("MSIA(PENANG,ESTEROL,TAMPOI) Reporting Template.xlsm").Worksheets("New Opps")
Set wsDest = Workbooks("CY All OPS APAC WORKING FILE MACRO WORKING FILE -
Copy.xlsm").Worksheets("SEA-Weekly New Opp")
lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
wsCopy.Range("A2:N" & lCopyLastRow).Copy _
wsDest.Range("A4")
Workbooks("MSIA(PENANG,ESTEROL,TAMPOI) Reporting Template.xlsm").Close SaveChanges:=True
Workbooks.Open "Z:\SFDC Reporting\MSIA(Plentong) Reporting Template.xlsm", Password:="Phyllis"
Set wsCopy = Workbooks("MSIA(Plentong) Reporting Template.xlsm").Worksheets("New Opps")
Set wsDest = Workbooks("CY All OPS APAC WORKING FILE MACRO WORKING FILE -
Copy.xlsm").Worksheets("SEA-Weekly New Opp")
lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
wsCopy.Range("A2:N" & lCopyLastRow).Copy _
wsDest.Range("A" & lDestLastRow)
Workbooks("MSIA(PLENTONG) Reporting Template.xlsm").Close SaveChanges:=True
Workbooks.Open "Z:\SFDC Reporting\INDONESIA Reporting Template.xlsm", Password:="Melinda"
Set wsCopy = Workbooks("INDONESIA Reporting Template.xlsm").Worksheets("New Opps")
Set wsDest = Workbooks("CY All OPS APAC WORKING FILE MACRO WORKING FILE -
Copy.xlsm").Worksheets("SEA-Weekly New Opp")
lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
wsCopy.Range("A2:N" & lCopyLastRow).Copy _
wsDest.Range("A" & lDestLastRow)
Workbooks("INDONESIA Reporting Template.xlsm").Close SaveChanges:=True
Workbooks.Open "Z:\SFDC Reporting\PHILIPPINES Reporting Template.xlsm", Password:="Janet"
excel
Consolidate Data from Multiple Worksheets
A Quick Fix
After each line...
lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "A").End(xlUp).Row
... you could use:
If lCopyLastRow > 1 Then
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
wsCopy.Range("A2:N" & lCopyLastRow).Copy wsDest.Range("A" & lDestLastRow)
End If
Workbooks("...").Close SaveChanges:=True ' 'False' seems more appropriate!?
An Improvement (Not Tested)
Sub createReport()
' Destination
Const dwbName As String = "CY All OPS APAC WORKING FILE MACRO WORKING " _
& "FILE - Copy.xlsm "
Const dwsName As String = "SEA-Weekly New Opp"""
Const dFirst As Long = 4
' Source
Const sPath As String = "Z:\SFDC Reporting\"
Const swsName As String = "New Opps"
Dim swbNames As Variant: swbNames = Array( _
"MSIA(PENANG,ESTEROL,TAMPOI) Reporting Template.xlsm", _
"MSIA(Plentong) Reporting Template.xlsm", _
"INDONESIA Reporting Template.xlsm", _
"PHILIPPINES Reporting Template.xlsm")
Dim swbPasswords As Variant: swbPasswords = Array( _
"Mingsee", "Phyllis", "Melinda", "Janet")
Const sFirst As Long = 2
' Both
Const bCols As String = "A:N"
Application.ScreenUpdating = False
Dim dCell As Range
With Workbooks(dwbName).Worksheets(dwsName).Columns(bCols).Rows(dFirst)
.Resize(.Worksheet.Rows.Count - .Row + 1).ClearContents
Set dCell = .Cells(1)
End With
Dim sws As Worksheet
Dim srg As Range
Dim sLast As Long
Dim n As Long
For n = LBound(swbNames) To UBound(swbNames)
Set sws = Workbooks.Open(Filename:=swbNames(n), _
Password:=swbPasswords(n)).Worksheets(swsName)
With sws.Columns(bCols)
sLast = .Columns(1).Cells(.Rows.Count).End(xlUp).Row
End With
If sLast >= sFirst Then
Set srg = sws.Columns(bCols).Rows(sFirst).Resize(sLast - sFirst + 1)
srg.Copy dCell
Set dCell = dCell.Offset(srg.Rows.Count)
End If
sws.Parent.Close SaveChanges:=False
Next n
Application.ScreenUpdating = True
End Sub
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")
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
I'm struggling with my code to copy data from 3 workbooks with same worksheet name to one master workbook also having the same name. The main problem is to define the last row. After I copy the first data set from the first workbook and then go to second one I want to paste the data below the first data in master workbook and so on. Do you guys have any suggestions?
Below is my unfinished code:
Sub refresh()
Dim wball, wb1, wb2, wb3 As Workbook
Dim ws, sht As Worksheet
Dim wbpath As String
Dim LastRow As Long
Application.ScreenUpdating = False
wbpath = Application.ThisWorkbook.Path
'wball = ThisWorkbook 'master workbook
Application.DisplayAlerts = False
'clears master wb
Set ws = ThisWorkbook.Worksheets("Tab")
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
On Error Resume Next
ws.Rows(3).ClearContents
'ws.Rows("3:" & LastRow).Delete
ws.Range("Tab").Delete
Set wb1 = Workbooks.Open(wbpath & "\file1.xlsm")
LastRow = wb1.Sheets("Tab").Cells(ws.Rows.Count, "A").End(xlUp).Row
ws.Range("A3:CD" & LastRow).Value = wb1.Sheets("Tab").Range("A3:CD" & LastRow).Value
Set wb2 = Workbooks.Open(wbpath & "\file2.xlsm")
LastRow = wb2.Sheets("Tab").Cells(ws.Rows.Count, "A").End(xlUp).Row
'ws.
ws.Range("A3:CD" & LastRow).Value = wb2.Sheets("Tab").Range("A3:CD" & LastRow).Value
wb1.Close SaveChanges:=False
wb2.Close SaveChanges:=False
Application.ScreenUpdating = True
End Sub
Ok, I have made some changes and everything is working now as it should be.
Sub refresh()
Dim masterwb As Workbook
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim wb3 As Workbook
Dim masterws As Worksheet
Dim ws As Worksheet
Dim wbpath As String
Dim LastRow As Long
Dim LastRowSource As Long
Dim LastRowDestination As Long
Application.ScreenUpdating = False
wbpath = Application.ThisWorkbook.Path
'masterwb = ThisWorkbook
Application.DisplayAlerts = False
'clears master wb
Set masterws = ThisWorkbook.Worksheets("Tab")
'LastRow = masterws.Cells(ws.Rows.Count, "A").End(xlUp).Row
masterws.Rows(3).ClearContents
masterws.Range("A4:CD9999").Delete
'start to copy data from 3 workbooks
Set wb1 = Workbooks.Open(wbpath & "\file1.xlsm")
LastRowDestination = wb1.Sheets("Tab").Cells(Rows.Count, "A").End(xlUp).Row
masterws.Range("A3:CD" & LastRowDestination).Value = wb1.Sheets("Tab").Range("A3:CD" & LastRowDestination).Value
LastRowSource = masterws.Cells(masterws.Rows.Count, "A").End(xlUp).Row + 1
'LastRowSource + LastRowDestination -3 because im getting 3 extra rows with #N/D
Set wb2 = Workbooks.Open(wbpath & "\file2.xlsm")
LastRowDestination = wb2.Sheets("Tab").Cells(Rows.Count, "A").End(xlUp).Row
masterws.Range("A" & LastRowSource & ":CD" & LastRowSource + LastRowDestination -3).Value = wb2.Sheets("Tab").Range("A3:CD" & LastRowDestination).Value
LastRowSource = masterws.Cells(masterws.Rows.Count, "A").End(xlUp).Row + 1
Set wb3 = Workbooks.Open(wbpath & "\file3.xlsm")
LastRowDestination = wb3.Sheets("Tab").Cells(Rows.Count, "A").End(xlUp).Row
masterws.Range("A" & LastRowSource & ":CD" & LastRowSource + LastRowDestination -3).Value = wb3.Sheets("Tab").Range("A3:CD" & LastRowDestination).Value
wb1.Close SaveChanges:=False
wb2.Close SaveChanges:=False
wb3.Close SaveChanges:=False
Application.ScreenUpdating = True
End Sub
Thanks for your help.