Hi Trying to get some help to see why this is not working in a Macro that I have setup. The area where the debugger causes an issue is at the 2nd Selection.Formula area.
Sub PrintAllonges()
'
' PrintAllonges Macro
'
' Keyboard Shortcut: Ctrl+Shift+Y
'
Dim pdfName As String, FullName As String, Path As String, lRow As Long
Set oFSO = CreateObject("Scripting.FileSystemObject")
Path = CreateObject("WScript.Shell").specialfolders("Desktop")
' Create Desktop Folder if not exists
If oFSO.FolderExists(Path & "\Allonges") Then
Else
MkDir Path & "\Allonges"
End If
'Turn off Screen Update
Sheets("MissingAllonges").Select
lRow = Cells(Rows.Count, 1).End(xlUp).Row
MsgBox (lRow)
Sheets("AllongeTemplate").Select
Application.ScreenUpdating = False
For i = 2 To lRow
Range("G6").Select
Selection.Formula = "=MissingAllonges!I" & i
Range("E11").Select
Selection.Formula = _
"=TEXT(MONTH(MissingAllonges!D" & i & "),""mmmm"")&"" ""&DAY(MissingAllonges!D" & i & ")&"", ""&YEAR(MissingAllonges!D" & i & ")"""
pdfName = Sheets("AllongeTemplate").Range("H7").Value & " - " & Sheets("AllongeTemplate").Range("G6").Value & " Allonge"
FullName = Path & "\Allonges\" & pdfName & ".pdf"
ActiveWorkbook.ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FullName, OpenAfterPublish:=False
Next i
Application.ScreenUpdating = True
End Sub
I put this in and got to work for other formulas where I am updating the loop but I can't get this to work and getting an error on syntax.
You have extra quotation marks at the end of the formula.
The corrected formula would be:
.Formula = "=TEXT(MONTH(MissingAllonges!D" & i & "),""mmmm"")&"" ""&DAY(MissingAllonges!D" & i & ")&"", ""&YEAR(MissingAllonges!D" & i & ")"
But I agree with #BigBen that the formula could be simplified, ie:
.Formula = "=TEXT(MissingAllonges!D" & i & ", ""mmmm d, yyyy"")"
Sub ExportCreatePOD()
'File names to be created as " & " " & "-" & " " & "POL" & " " & "-" & " " & Format(Now()," MM-DD-YYYY ")"
Dim RngSourceData As Range
Dim RngTarget As Range
Dim RngRange01 As Range
Dim RngRange02 As Range
Dim StrCarrierColumnHeader As String
Dim StrSavePath As String
Dim StrMultipleFileMessage As String
Dim DblCarrierColumnRelativeColumn As Double
Dim DblCounter01 As Double
Dim DblCounter02 As Double
Dim WkbSource As Workbook
Dim WkbTarget As Workbook
'Turning off screen updating.
Application.ScreenUpdating = False
'Setting variables.
Set WkbSource = ActiveWorkbook
Set RngSourceData = WkbSource.Sheets("POD").UsedRange
StrCarrierColumnHeader = "Carrier"
StrSavePath = "C:Path\" '=== Path for POD files Change the Path (where you want to export the POD files)
On Error Resume Next
DblCarrierColumnRelativeColumn = Excel.WorksheetFunction.Match(StrCarrierColumnHeader, RngSourceData.Rows(1), 0)
If Err <> 0 Then
MsgBox "The range " & RngSourceData.Rows(1).Address(False, False) & " contains no column headed " & StrCarrierColumnHeader & ". The subroutine is terminated", vbCritical, "Error"
Application.ScreenUpdating = True
Exit Sub
End If
On Error GoTo 0
Set RngRange01 = RngSourceData.Columns(DblCarrierColumnRelativeColumn).Resize(RngSourceData.Rows.Count - 1).Offset(1, 0)
DblCounter01 = 0
For Each RngTarget In RngRange01.Cells
If Excel.WorksheetFunction.CountIf(RngSourceData.Parent.Range(RngRange01.Cells(1, 1), RngTarget), RngTarget.Value) = 1 Then
'Cheking if any file dedicated to the given carrier already exists for today.
If Dir(StrSavePath & RngTarget.Value & " " & "-" & " " & "POD" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & ".xlsx") = "" Then
'If no such file exists, it is created and saved.
Set WkbTarget = Workbooks.Add
WkbTarget.SaveAs StrSavePath & RngTarget.Value & " " & "-" & " " & "POD" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & ".xlsx"
Else
'Is it does exist, the name is "shifted".
DblCounter02 = 2
Do Until Dir(StrSavePath & RngTarget.Value & " " & "-" & " " & "POD" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & "(" & DblCounter02 & ")" & ".xlsx") = ""
DblCounter02 = DblCounter02 + 1
Loop
'Carrier and relative file are copied in StrMultipleFileMessage.
StrMultipleFileMessage = StrMultipleFileMessage & vbCrLf & RngTarget.Value & " in " & RngTarget.Value & " " & "-" & " " & "POD" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & "(" & DblCounter02 & ")" & ".xlsx"
Set WkbTarget = Workbooks.Add
WkbTarget.SaveAs StrSavePath & RngTarget.Value & " " & "-" & " " & "POD" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & "(" & DblCounter02 & ")" & ".xlsx"
End If
'Setting RngRange02 to target the range in the new file where RngSourceData will be copied.
Set RngRange02 = WkbTarget.Sheets(1).Range("A1").Resize(RngSourceData.Rows.Count, RngSourceData.Columns.Count)
With RngRange02
'Copying values.
RngSourceData.Copy RngRange02
'Filtering the range to clear the list of unwanted data.
.AutoFilter Field:=DblCarrierColumnRelativeColumn, Criteria1:="<>" & RngTarget.Value
.Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0).ClearContents
.Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0).ClearFormats
'Removing the filter.
.AutoFilter
'Rename Sheet
Sheets("Sheet1").Name = "POD"
'Autofit
Sheets("POD").UsedRange.Columns.AutoFit
'Sorting the range to compact the data.
With .Parent.Sort
.SortFields.Clear
.SortFields.Add Key:=RngRange02.Columns(DblCarrierColumnRelativeColumn), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
.SetRange RngRange02
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
'Saving and closing WkbTarget.
WkbTarget.Close SaveChanges:=True
End If
'Setting DblCounter01.
DblCounter01 = DblCounter01 + 1
Next
'Enabling screen updating.
Application.ScreenUpdating = True
'Reporting if any carrier had its data reported in a "twin" file.
If StrMultipleFileMessage <> "" Then
StrMultipleFileMessage = "The following carriers had already one or more dedicated files at the given path. Their data were saved accordingly to this list:" & vbCrLf & vbCrLf & StrMultipleFileMessage
MsgBox StrMultipleFileMessage, , "Multiple dedicated files"
End If
End Sub
I created a macro that split data based on column name "Carrier" into a new excel file. I have 2 tabs named POL and POD for which I created 2 sets of codes that split data from these tabs based on the column name and created a new excel file, my code for tab POL is working but not for POD. I neither get any error it just executes and create a file but does not paste any data of the POD tab.
Main Excel File which has Macro codes Problem in Tab POD
In this above screen, you can see the POD tab has so much data that macro should create a new file based on column name "Carrier". When I execute the macro it create a new file but there is no data in it meaning the data does not get captured in the newly created POD file. I am pasting the output as follows.
Wrong Output
If you see in the above image no data is captured in the newly created file.
I will paste my complete code below the codes for both the tabs POL and POD. Please guide is there any easy way to cut short the codes that read both POL and POD tabs and create/splits the data into a new excel file based on the column named carrier. However, at present, the problem is with the codes within "
Sub ExportCreatePOD()"
My Complete Codes :-
'--------------------------------Create POL POD XL Sheets---------------------------
Sub ExportCreatePOL()
'File names to be created as " & " " & "-" & " " & "POL" & " " & "-" & " " & Format(Now()," MM-DD-YYYY ")"
Dim RngSourceData As Range
Dim RngTarget As Range
Dim RngRange01 As Range
Dim RngRange02 As Range
Dim StrCarrierColumnHeader As String
Dim StrSavePath As String
Dim StrMultipleFileMessage As String
Dim DblCarrierColumnRelativeColumn As Double
Dim DblCounter01 As Double
Dim DblCounter02 As Double
Dim WkbSource As Workbook
Dim WkbTarget As Workbook
Application.ScreenUpdating = False
Set WkbSource = ActiveWorkbook
Set RngSourceData = WkbSource.Sheets("POL").UsedRange
StrCarrierColumnHeader = "Carrier"
StrSavePath = "C:Path\" '===Path where excel files will be created Change the Path (where you want to export the POL files)
'Setting DblCarrierColumnRelativeColumn to determine what column within RngSourceData _
contains the StrCarrierColumnHeader. If no such column is found, the subroutine is terminated.
On Error Resume Next
DblCarrierColumnRelativeColumn = Excel.WorksheetFunction.Match(StrCarrierColumnHeader, RngSourceData.Rows(1), 0)
If Err <> 0 Then
MsgBox "The range " & RngSourceData.Rows(1).Address(False, False) & " contains no column headed " & StrCarrierColumnHeader & ". The subroutine is terminated", vbCritical, "Error"
Application.ScreenUpdating = True
Exit Sub
End If
On Error GoTo 0
Set RngRange01 = RngSourceData.Columns(DblCarrierColumnRelativeColumn).Resize(RngSourceData.Rows.Count - 1).Offset(1, 0)
DblCounter01 = 0
For Each RngTarget In RngRange01.Cells
If Excel.WorksheetFunction.CountIf(RngSourceData.Parent.Range(RngRange01.Cells(1, 1), RngTarget), RngTarget.Value) = 1 Then
If Dir(StrSavePath & RngTarget.Value & " " & "-" & " " & "POL" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & ".xlsx") = "" Then
Set WkbTarget = Workbooks.Add
WkbTarget.SaveAs StrSavePath & RngTarget.Value & " " & "-" & " " & "POL" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & ".xlsx"
Else
'Is it does exist, the name is "shifted".
DblCounter02 = 2
Do Until Dir(StrSavePath & RngTarget.Value & " " & "-" & " " & "POL" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & "(" & DblCounter02 & ")" & ".xlsx") = ""
DblCounter02 = DblCounter02 + 1
Loop
'Carrier and relative file are copied in StrMultipleFileMessage.
StrMultipleFileMessage = StrMultipleFileMessage & vbCrLf & RngTarget.Value & " in " & RngTarget.Value & " " & "-" & " " & "POL" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & "(" & DblCounter02 & ")" & ".xlsx"
Set WkbTarget = Workbooks.Add
WkbTarget.SaveAs StrSavePath & RngTarget.Value & " " & "-" & " " & "POL" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & "(" & DblCounter02 & ")" & ".xlsx"
End If
'Setting RngRange02 to target the range in the new file where RngSourceData will be copied.
Set RngRange02 = WkbTarget.Sheets(1).Range("A1").Resize(RngSourceData.Rows.Count, RngSourceData.Columns.Count)
With RngRange02
'Copying values.
RngSourceData.Copy RngRange02
'Filtering the range to clear the list of unwanted data.
.AutoFilter Field:=DblCarrierColumnRelativeColumn, Criteria1:="<>" & RngTarget.Value
.Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0).ClearContents
.Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0).ClearFormats
'Removing the filter.
.AutoFilter
'Rename sheet1
Sheets("Sheet1").Name = "POL"
'Autofit
Sheets("POL").UsedRange.Columns.AutoFit
'Sorting the range to compact the data.
With .Parent.Sort
.SortFields.Clear
.SortFields.Add Key:=RngRange02.Columns(DblCarrierColumnRelativeColumn), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
.SetRange RngRange02
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
'Saving and closing WkbTarget.
WkbTarget.Close SaveChanges:=True
End If
'Setting DblCounter01.
DblCounter01 = DblCounter01 + 1
Next
'Enabling screen updating.
Application.ScreenUpdating = True
'Reporting if any carrier had its data reported in a "twin" file.
If StrMultipleFileMessage <> "" Then
StrMultipleFileMessage = "The following carriers had already one or more dedicated files at the given path. Their data were saved accordingly to this list:" & vbCrLf & vbCrLf & StrMultipleFileMessage
MsgBox StrMultipleFileMessage, , "Multiple dedicated files"
End If
End Sub
Sub ExportCreatePOD()
'File names to be created as " & " " & "-" & " " & "POL" & " " & "-" & " " & Format(Now()," MM-DD-YYYY ")"
Dim RngSourceData As Range
Dim RngTarget As Range
Dim RngRange01 As Range
Dim RngRange02 As Range
Dim StrCarrierColumnHeader As String
Dim StrSavePath As String
Dim StrMultipleFileMessage As String
Dim DblCarrierColumnRelativeColumn As Double
Dim DblCounter01 As Double
Dim DblCounter02 As Double
Dim WkbSource As Workbook
Dim WkbTarget As Workbook
'Turning off screen updating.
Application.ScreenUpdating = False
'Setting variables.
Set WkbSource = ActiveWorkbook
Set RngSourceData = WkbSource.Sheets("POD").UsedRange
StrCarrierColumnHeader = "Carrier"
StrSavePath = "C:Path\" '=== Path for POD files Change the Path (where you want to export the POD files)
On Error Resume Next
DblCarrierColumnRelativeColumn = Excel.WorksheetFunction.Match(StrCarrierColumnHeader, RngSourceData.Rows(1), 0)
If Err <> 0 Then
MsgBox "The range " & RngSourceData.Rows(1).Address(False, False) & " contains no column headed " & StrCarrierColumnHeader & ". The subroutine is terminated", vbCritical, "Error"
Application.ScreenUpdating = True
Exit Sub
End If
On Error GoTo 0
Set RngRange01 = RngSourceData.Columns(DblCarrierColumnRelativeColumn).Resize(RngSourceData.Rows.Count - 1).Offset(1, 0)
DblCounter01 = 0
For Each RngTarget In RngRange01.Cells
If Excel.WorksheetFunction.CountIf(RngSourceData.Parent.Range(RngRange01.Cells(1, 1), RngTarget), RngTarget.Value) = 1 Then
'Cheking if any file dedicated to the given carrier already exists for today.
If Dir(StrSavePath & RngTarget.Value & " " & "-" & " " & "POD" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & ".xlsx") = "" Then
'If no such file exists, it is created and saved.
Set WkbTarget = Workbooks.Add
WkbTarget.SaveAs StrSavePath & RngTarget.Value & " " & "-" & " " & "POD" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & ".xlsx"
Else
'Is it does exist, the name is "shifted".
DblCounter02 = 2
Do Until Dir(StrSavePath & RngTarget.Value & " " & "-" & " " & "POD" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & "(" & DblCounter02 & ")" & ".xlsx") = ""
DblCounter02 = DblCounter02 + 1
Loop
'Carrier and relative file are copied in StrMultipleFileMessage.
StrMultipleFileMessage = StrMultipleFileMessage & vbCrLf & RngTarget.Value & " in " & RngTarget.Value & " " & "-" & " " & "POD" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & "(" & DblCounter02 & ")" & ".xlsx"
Set WkbTarget = Workbooks.Add
WkbTarget.SaveAs StrSavePath & RngTarget.Value & " " & "-" & " " & "POD" & " " & "-" & " " & Format(Now(), " MM-DD-YYYY ") & "(" & DblCounter02 & ")" & ".xlsx"
End If
'Setting RngRange02 to target the range in the new file where RngSourceData will be copied.
Set RngRange02 = WkbTarget.Sheets(1).Range("A1").Resize(RngSourceData.Rows.Count, RngSourceData.Columns.Count)
With RngRange02
'Copying values.
RngSourceData.Copy RngRange02
'Filtering the range to clear the list of unwanted data.
.AutoFilter Field:=DblCarrierColumnRelativeColumn, Criteria1:="<>" & RngTarget.Value
.Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0).ClearContents
.Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0).ClearFormats
'Removing the filter.
.AutoFilter
'Rename Sheet
Sheets("Sheet1").Name = "POD"
'Autofit
Sheets("POD").UsedRange.Columns.AutoFit
'Sorting the range to compact the data.
With .Parent.Sort
.SortFields.Clear
.SortFields.Add Key:=RngRange02.Columns(DblCarrierColumnRelativeColumn), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
.SetRange RngRange02
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
'Saving and closing WkbTarget.
WkbTarget.Close SaveChanges:=True
End If
'Setting DblCounter01.
DblCounter01 = DblCounter01 + 1
Next
'Enabling screen updating.
Application.ScreenUpdating = True
'Reporting if any carrier had its data reported in a "twin" file.
If StrMultipleFileMessage <> "" Then
StrMultipleFileMessage = "The following carriers had already one or more dedicated files at the given path. Their data were saved accordingly to this list:" & vbCrLf & vbCrLf & StrMultipleFileMessage
MsgBox StrMultipleFileMessage, , "Multiple dedicated files"
End If
End Sub
Since you are copying all the data, filtering and then deleting unwanted records I suspect the problem is with the data. Try this more direct approach of copying only what you want.
Option Explicit
Sub ExportCreateBoth()
Call ExportCreateFile("POD")
Call ExportCreateFile("POL")
End Sub
Sub ExportCreateFile(ws_name As String)
Const COL_NAME = "Carrier"
Const SAVEPATH = "C:\temp\so\" ' ouput folder
Dim wb As Workbook, wbOut As Workbook
Dim ws As Worksheet, wsOut As Worksheet
Dim rng As Range, r As Long
Dim iCol As Integer, iLastCol As Integer, iLastRow As Long
Dim filename As String, msg As String
Set wb = ActiveWorkbook
Set ws = wb.Sheets(ws_name)
iLastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
Set rng = ws.Range("A1").Resize(1, iLastCol).Find(COL_NAME)
If rng Is Nothing Then
msg = "The range " & ws.Rows(1).Address() & " contains no column headed " _
& COL_NAME & ". The subroutine is terminated"
MsgBox msg, vbCritical
Exit Sub
End If
' carrier column
iCol = rng.Column
iLastRow = ws.Cells(Rows.Count, iCol).End(xlUp).Row
Set rng = ws.Range("A1").Resize(iLastRow, iLastCol)
' create list of unique values
Dim dict, key
Set dict = CreateObject("Scripting.Dictionary")
For r = 2 To iLastRow
key = Trim(ws.Cells(r, iCol))
If Len(key) > 0 Then dict(key) = 1
Next
' create workbooks for each carrier
Application.ScreenUpdating = False
For Each key In dict.keys
' create output workbook
filename = GetFileName(SAVEPATH, key, ws_name, msg)
Set wbOut = Workbooks.Add
Set wsOut = wbOut.Sheets(1)
wsOut.Name = ws_name
' copy filtered data
rng.AutoFilter Field:=iCol, Criteria1:=CStr(key)
rng.SpecialCells(xlCellTypeVisible).Copy _
wsOut.Range("A1")
wsOut.UsedRange.Columns.AutoFit
wbOut.SaveAs filename
wbOut.Close False
rng.AutoFilter
Next
Application.ScreenUpdating = True
If Len(msg) > 0 Then
msg = "The following carriers had already one or more " & _
"dedicated files at the given path. " & _
"Their data were saved accordingly to this list:" & msg & vbCrLf
MsgBox msg, vbExclamation, "Multiple dedicated files"
End If
MsgBox dict.Count & " files created for " & ws_name, vbInformation
End Sub
Function GetFileName(folder, carrier, str, ByRef msg) As String
Const EXT = ".xlsx"
Dim mdy As String, filename As String, s As String, n As Integer
mdy = Format(Now(), " MM-DD-YYYY ")
filename = folder & carrier & " - " & str & " - " & mdy
s = filename & EXT
n = 1
Do Until Dir(s) = ""
s = filename & "(" & n & ")" & EXT
n = n + 1
Loop
If n > 1 Then
msg = msg & vbLf & carrier & " in " & s
End If
GetFileName = s
End Function
I know this code is a mess but it's been at least working with no errors for weeks. The directories of all the files in question exist.
'''
Sub NEW_PO()
'''''''''''''''''''''''''''''''''''Declare Variables''''''''''''''''''''''''''''''''''''''''''''
Dim disc As String
Dim New_Data_Column As Long 'last date ordered column (number)
Dim NewPO_num As String 'New_Data_Column - 10 (needs leading "0" for single digits)
Dim Job_Num As String '= C2
Dim Cost_Code As String '= Active sheet name
Dim lastCol As String 'last date ordered column (Letter)
Dim sht As Worksheet
Dim lastRow As Long 'last row of description column
Set sht = ActiveSheet
''''''''''''''''''''''Find last row and column(letter)''''''''''''''''''''''''''''''''''''''''''
New_Data_Column = Cells(8, Columns.count).End(xlToLeft).Column
lastCol = Split(Columns(Range("A8").End(xlToRight).Column).Address(, False), ":")(1)
lastRow = sht.Cells(sht.Rows.count, 3).End(xlUp).Row
'''''''''''''''''''''''''''''Check for Data'''''''''''''''''''''''''''''''''''''''''''''''''''''
If WorksheetFunction.CountA(Range(lastCol & "11:" & lastCol & lastRow)) = 0 Then
MsgBox "Error! Please enter data to continue."
Exit Sub
ElseIf WorksheetFunction.CountA(Range(lastCol & "10")) = 0 Then
MsgBox "Error! Please enter date to continue."
Range(lastCol & "10").Select
Exit Sub
Else
''''''''''''''''''''''''''''''''Propmt for description of PO''''''''''''''''''''''''''''''''''''
disc = InputBox("Please enter a description for this Purchase Order.", "New Purchase Order")
If disc = "" Then
MsgBox "You Must Enter A Description!"
Exit Sub
End If
''''''''''''''''''''''''''''''''''Set Cost Code''''''''''''''''''''''''''''''''''''''''''''''''
Cost_Code = sht.name
'''''''''''''''''''''''''''''''''Set Job Number''''''''''''''''''''''''''''''''''''''''''''''''
Job_Num = sht.Cells(2, 4).Text 'as text to keep formatting
'''''''''''''''''''''''''''''Set New Purchase Order Number'''''''''''''''''''''''''''''''''''''
sht.Range("A4").Value = sht.Range("A4").Value + 1
If sht.Range("A4").Value < 10 Then
NewPO_num = "0" & sht.Range("A4").Value
Else
NewPO_num = sht.Range("A4").Value
End If
''''''''''''Open PO Template and save as PO number & Copy PO to S/R Log''''''''''''''''''''
Dim sPath As String
sPath = Application.ThisWorkbook.path
Dim i As Integer
Dim wkb1 As Workbook
Dim sht1 As Worksheet
Dim wkb2 As Workbook
Dim sht2 As Worksheet
Dim lastPO_row As Long
Dim lastSR_row As Long
Dim wkb3 As Workbook
Dim sht3 As Worksheet
Dim sht4 As Worksheet
Application.ScreenUpdating = False
Set wkb1 = ThisWorkbook
Set wkb2 = Workbooks.Open(sPath & "\1 CONSTRUCTION\Purchase Orders\Purchase Order Template.xlsm")
Set wkb3 = Workbooks.Open(sPath & "\1 CONSTRUCTION\RECEIVED MATERIALS\SR Log.xlsx")
Set sht1 = wkb1.Sheets(Cost_Code)
Set sht2 = wkb2.Sheets("Sheet1")
Set sht3 = wkb3.Sheets("Sheet1")
Set sht4 = wkb2.Sheets("Job Addresses")
'''
This is where the error is occurring. Normally it would save the template as specified with no problems. I have deleted the code and written it in notepad and pasted it back into excel and it still gives an error. I've tried on multiple computers with the same result. I even uninstalled and reinstalled office and still not working.
'''
wkb2.SaveAs (sPath & "\1 CONSTRUCTION\Purchase Orders\" & Cost_Code & "\" & Job_Num & "-" & NewPO_num
& "-" & Cost_Code & " " & disc & ".xlsm")
wkb3.SaveAs (sPath & "\1 CONSTRUCTION\RECEIVED MATERIALS\" & Cost_Code & "\" & Job_Num & "-" &
NewPO_num & "-" & Cost_Code & " " & disc & ".xlsx")
sht2.name = Job_Num & "-" & NewPO_num & "-" & Cost_Code & " " & disc
lastPO_row = sht2.Cells(sht.Rows.count, 3).End(xlUp).Row + 1
lastSR_row = sht3.Cells(sht.Rows.count, 1).End(xlUp).Row + 1
''''''''''''Copy relevant entries to PO sheet and Shipping/Receiving Log'''''''''''''''''''
For i = 11 To lastRow
If sht1.Cells(i, New_Data_Column).Value <> "" Then
sht1.Range(lastCol & i).Copy
sht2.Range("A" & lastPO_row).PasteSpecial xlPasteValues
sht3.Range("D" & lastSR_row).PasteSpecial xlPasteValues
sht1.Range("B" & i & ":C" & i).Copy
sht2.Range("B" & lastPO_row & ":C" & lastPO_row).PasteSpecial xlPasteValues
sht3.Range("A" & lastSR_row & ":B" & lastSR_row).PasteSpecial xlPasteValues
lastPO_row = lastPO_row + 1
lastSR_row = lastSR_row + 1
End If
Next
sht2.Range("E6").Value = wkb1.Sheets("PM Dashboard").Range("O3").Value
sht2.Range("E7").Value = Job_Num & "-" & NewPO_num & "-" & Cost_Code
sht2.Range("E8").Value = Dashboard.Sheets("PM Dashboard").Range("Y2").Value
'add this job's address to list of addresses on PO
sht4.Range("A7").Value = wkb1.Sheets("PM Dashboard").Range("O3").Value & vbNewLine _
& wkb1.Sheets("PM Dashboard").Range("AP3").Value & vbNewLine & wkb1.Sheets("PM
Dashboard").Range("AP4").Value
wkb2.Save
sht3.Range("C1").Value = Job_Num & "-" & NewPO_num & "-" & Cost_Code & " " & disc
wkb3.Save
wkb3.Close
'''''''''''''''''''''copy over last column and hide previous'''''''''''''''''''''
sht1.Columns(New_Data_Column).Copy
sht1.Columns(New_Data_Column + 1).PasteSpecial Paste:=xlPasteFormats
sht1.Range(lastCol & "8:" & lastCol & "9").Copy
sht1.Range(lastCol & "8:" & lastCol & "9").Offset(0, 1).PasteSpecial Paste:=xlPasteValues
Call HIDE
wkb1.Save
Application.ScreenUpdating = True
End If
End Sub
'''
I'm trying to copy a lot of workbooks into a summary workbook, I've gotten the below code to do the job so far.
Option Explicit
Const FOLDER_PATH = "Folderpath\" 'REMEMBER END BACKSLASH
Sub ImportWorksheets()
'=============================================
'Process all Excel files in specified folder
'=============================================
Dim sFile As String 'file to process
Dim wsTarget As Worksheet
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim rowTarget As Long 'output row
rowTarget = Sheets("Status").Cells(Rows.Count, "AK").End(xlUp).Row + 1
'check the folder exists
If Not FileFolderExists(FOLDER_PATH) Then
MsgBox "Specified folder does not exist, exiting!"
Exit Sub
End If
'reset application settings in event of error
'On Error GoTo errHandler
'Application.ScreenUpdating = False
'set up the target worksheet
Set wsTarget = Sheets("Status")
'loop through the Excel files in the folder
sFile = Dir(FOLDER_PATH & "*.xls*")
Do Until sFile = ""
'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
Set wsSource = wbSource.Worksheets("Side 1-Forside") 'EDIT IF NECESSARY
'import the data
With wsTarget
.Activate
wsSource.Range("C14").Copy
.Range("A" & rowTarget).Select
ActiveSheet.Paste Link:=True
wsSource.Range("C15").Copy
.Range("B" & rowTarget).Select
ActiveSheet.Paste Link:=True
wsSource.Range("C13").Copy
.Range("C" & rowTarget).Select
ActiveSheet.Paste Link:=True
wsSource.Range("I11").Copy
.Range("J" & rowTarget).Select
ActiveSheet.Paste Link:=True
wsSource.Range("I10").Copy
.Range("K" & rowTarget).Select
ActiveSheet.Paste Link:=True
wsSource.Range("C40").Copy
.Range("L" & rowTarget).Select
ActiveSheet.Paste Link:=True
wsSource.Range("E40").Copy
.Range("M" & rowTarget).Select
ActiveSheet.Paste Link:=True
wsSource.Range("I9").Copy
.Range("H" & rowTarget).Select
ActiveSheet.Paste Link:=True
'optional source filename in the last column
.Range("AK" & rowTarget).Value = sFile
End With
'close the source workbook, increment the output row and get the next file
wbSource.Close SaveChanges:=False
rowTarget = rowTarget + 1
sFile = Dir()
Loop
'errHandler:
'On Error Resume Next
'Application.ScreenUpdating = True
'tidy up
Set wsSource = Nothing
Set wbSource = Nothing
Set wsTarget = Nothing
End Sub
Private Function FileFolderExists(strPath As String) As Boolean
If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function
However is it possible to grab the data as a link instead of a "dead" value? So if it gets changed in one of the many workbooks, I just have to refresh the summary workbook?
Bonusquestion: Is it possible to check for duplicates in this bit: .Range("AK" & rowTarget).Value = sFile and only add if the values isn't there already and the new values should add from the last empty row below row 5?
You could copy the source range and then use Special Paste › Paste Link in the destination workbook. It pastes a formula linking to the source workbooks copied range.
This short YouTube video should illustrate it best.
You could also do that with VBA if necessary e.g:
wsSource.Range("C14").Copy
.Range("A" & rowTarget).Select
ActiveSheet.Paste Link:=True
It seems like we need to .Select first and use ActiveSheet.Paste otherwise the link pasting fails, even if that looks like a bad practice, but the below direct referencing the range won't work!
wsSource.Range("C14").Copy
.Range("A" & rowTarget).Paste Link:=True 'fails with error 438
But because you are linking the values now with a formula you probably need to do that only once and therefore don't need the VBA solution anymore, because it is easier to do it once by hand.
Note:
be aware that these workbooks are linked by a formula then. If you move the source workbook into another location the link will break (if the destination workbook is not within the same location and copied as well). This comes with all the downsides of linked workbooks.
//edit
With wsTarget
.Activate
.Range("A" & rowTarget).Select
wsSource.Range("C14").Copy
.Paste Link:=True
.Activate
.Range("B" & rowTarget).Select
wsSource.Range("C15").Copy
.Paste Link:=True
Alternative solution to the one suggested by Peh, both work, though the one below is not as flexible but hardcoded instead. Thought I would share.
Option Explicit
Const FOLDER_PATH = "Folderpath\" 'REMEMBER END BACKSLASH
Sub ImportWorksheets()
'=============================================
'Process all Excel files in specified folder
'=============================================
Dim sFile As String 'file to process
Dim wsTarget As Worksheet
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim rowTarget As Long 'output row
rowTarget = Sheets("Status").Cells(Rows.Count, "AK").End(xlUp).Row + 1
'check the folder exists
If Not FileFolderExists(FOLDER_PATH) Then
MsgBox "Specified folder does not exist, exiting!"
Exit Sub
End If
'reset application settings in event of error
'On Error GoTo errHandler
'Application.ScreenUpdating = False
'set up the target worksheet
Set wsTarget = Sheets("Status")
'loop through the Excel files in the folder
sFile = Dir(FOLDER_PATH & "*.xls*")
Do Until sFile = ""
'import the data
With wsTarget
'optional source filename in the last column
.Range("AK" & rowTarget).Value = sFile
.Range("A" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$C$14"
.Range("B" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$C$15"
.Range("C" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$C$13"
.Range("J" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$I$11"
.Range("K" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$I$10"
.Range("L" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$C$40"
.Range("M" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$E$40"
.Range("H" & rowTarget).Value = "=" & "'" & FOLDER_PATH & "[" & .Range("AK" & rowTarget).Value & "]" & "Side 1-Forside" & "'" & "!$I$9"
End With
'close the source workbook, increment the output row and get the next file
rowTarget = rowTarget + 1
sFile = Dir()
Loop
'errHandler:
'On Error Resume Next
'Application.ScreenUpdating = True
'tidy up
Set wsSource = Nothing
Set wbSource = Nothing
Set wsTarget = Nothing
End Sub
Private Function FileFolderExists(strPath As String) As Boolean
If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function
Try this AddIn. It will do exactly what you want.
https://www.rondebruin.nl/win/addins/rdbmerge.htm
I am working on a save to pdf export from a loop function. I have set the file_name as:
Sub AutoFill_export2pdf()
'
Dim rowCount As Integer
Dim CurBU As String
Dim CurOPRID As String
Dim CurName As String
Dim CurJournalID As String
Dim CurJournalDate As String
Dim FILE_NAME As String
Sheets("List").Select
rowCount = ActiveSheet.UsedRange.Rows.count
Set Destsh = ActiveWorkbook.Sheets("Sheet")
For sourceRow = 2 To rowCount
CurOPRID = Range("A" & CStr(sourceRow)) 'OPRID
CurName = Range("B" & CStr(sourceRow)) 'Name
CurBU = Range("C" & CStr(sourceRow)) 'BU
CurJournalID = Range("D" & CStr(sourceRow)) 'Journal ID
CurJournalDate = Range("E" & CStr(sourceRow)) 'Journal Date
FILE_NAME = ActiveWorkbook.Path & "\" & "OTGL_" & "JRNL_" & CurBU & "_" & CurJournalID & "_" & Format(CurJournalDate, "mm-dd-yyyy") & "_" & ".PDF"
CurName = "*" & CurName & "*"
CurBU = "*" & CurBU & "*"
CurJournalID = "*" & CurJournalID & "*"
CurJournalDate = "*" & CurJournalDate & "*"
Destsh.Range("K27") = CurName
Destsh.Range("D7") = CurBU
Destsh.Range("G7") = CurJournalID
Destsh.Range("I7") = CurJournalDate
On Error GoTo 0
Call SaveAsPDF(Destsh, FILE_NAME)
Sheets("List").Select
Next
End Sub
Public Sub SaveAsPDF(ByVal destSheet As Worksheet, ByVal PDFName As String)
On Error Resume Next
Kill PDFName
destSheet.Activate
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:=FILE_NAME, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End Sub
Sub Autofill()
'
Dim rowCount As Integer
Dim CurBU As String
Dim CurName As String
Dim CurOPRID As String
Dim CurJournalID As String
Dim CurJournalDate As String
Dim FILE_NAME As String
CurName = "*" & CurName & "*"
CurBU = "*" & CurBU & "*"
CurJournalID = "*" & CurJournalID & "*"
CurJournalDate = "*" & CurJournalDate & "*"
Sheets("List").Select
rowCount = ActiveSheet.UsedRange.Rows.count
Set Destsh = ActiveWorkbook.Sheets("Sheet")
For sourceRow = 2 To rowCount
CurOPRID = Range("A" & CStr(sourceRow)) 'OPRID
CurName = Range("B" & CStr(sourceRow)) 'Name
CurBU = Range("C" & CStr(sourceRow)) 'BU
CurJournalID = Range("D" & CStr(sourceRow)) 'Journal ID
CurJournalDate = Range("E" & CStr(sourceRow)) 'Journal Date
FILE_NAME = ActiveWorkbook.Path & "\" & "OTGL_" & "JRNL_" & CurBU & "_" & CurJournalID & "_" & Format(CurJournalDate, "mm-dd-yyyy") & "_" & ".PDF"
Destsh.Range("K27") = CurName
Destsh.Range("D7") = CurBU
Destsh.Range("G7") = CurJournalID
Destsh.Range("I7") = CurJournalDate
On Error GoTo 0
Call SaveAsPDF(Destsh, FILE_NAME)
Sheets("List").Select
Next
End Sub
The goal is to export to a specific folder with the naming convention I have established. If you need the entire macro, please let me know.
In the interest of teaching to fish vs handing out fish...
Put option explicit at the very top (even before your first sub).
Open your locals window (View in the VBE). Step through your code with F8, watching your variables in the locals window to ensure that they are what you expect them to be at that step in your script.
Option explicit will identify numberous variables that you haven't
declared. ("Variable not defined")
Fix those and any other issues that come up. (When it goes to other subs it will ID issues with variables there also.)
Your issue might go away just fixing what option explicit identifies and/or it might become apparent stepping through your code and watching the locals window each time you hit F8.
If you are still stuck, then edit your post with your updated code and explain any error message and line it is occurring on. If there isn't an error explain the expected and actual behavior.
The above code works perfectly, the file I was working off of was a copy with an identical name saved in the temp folder, so all the files were saving into the active workbook path..which wasnt in the folder I was monitoring. I have about 30000 pdfs in there now from running the macro so many times, lol! Thanks to all who tried to help.