What is causing my code to have 1004 runtime error - excel

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
'''

Related

Sort items per customer

I am making a tool in excel VBA to bulk create some kind of invoices to each customer. We are making LIVE streams and selling kids clothing, then we write all our orders to excel sheet. Example:
orders list
Then we have to sort all those orders by customer (there are many of them) and create some kind of invoice for each customer. Example: "invoice template"
I use this code to bulk create those and download as pdfs.
Sub Create_PDF_Files()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim dsh As Worksheet
Dim tsh As Worksheet
Dim setting_Sh As Worksheet
Set dsh = ThisWorkbook.Sheets("uzsakymai")
Set tsh = ThisWorkbook.Sheets("lapukas")
Set setting_Sh = ThisWorkbook.Sheets("Settings")
Application.DisplayStatusBar = True
Application.StatusBar = ""
Dim i As Integer
Dim File_Name As String
For i = 2 To dsh.Range("A" & Application.Rows.Count).End(xlUp).Row
Application.StatusBar = i - 1 & "/" & dsh.Range("A" & Application.Rows.Count).End(xlUp).Row - 1
tsh.Range("D1").Value = dsh.Range("C" & i).Value
tsh.Range("A4").Value = dsh.Range("B" & i).Value
tsh.Range("B4").Value = dsh.Range("A" & i).Value & " - " & dsh.Range("E" & i).Value
tsh.Range("P4").Value = dsh.Range("D" & i).Value
File_Name = dsh.Range("A" & i).Value & "(" & dsh.Range("C" & i).Value & "-" & dsh.Range("D" & i).Value & ").pdf"
tsh.ExportAsFixedFormat xlTypePDF, setting_Sh.Range("F4").Value & "\" & File_Name
Next i
Application.StatusBar = ""
MsgBox "Done"
End Sub
But what it does is creating invoice for each item.
EXAMPLE
Any ideas how could I make it work for me as I want it to work?
---EDIT---
After ALeXceL answer, it seems to have some bugs. I changed my code to his code, and I see some progress in creating this program, but what it does, is it shows first item correctly, but all the other items are appearing starting on A24 cell. EXAMPLE
---EDIT---
IT WORKS!!!
Assuming that "uzsakymai" is "orders", the 'data sheet' (dsh) and "lapukas" is the 'template' sheet (tsh), I did these changes, added some counters, in order to the logic flows the right way:
Important: before put this code to run you MUST classify the 'orders' table (dsh, or "uzsakymai") first by Name, then, by Size (as you wish, according to the images posted)
Option Explicit
Sub Create_PDF_Files()
Dim Orders_sh As Worksheet
Dim Template_sh As Worksheet
Dim setting_Sh As Worksheet
Dim oCell As Excel.Range
Dim strKey_TheName As String
Dim lngTemplate_A As Long
Dim lngSumOfItems As Long
Dim dblSumOfValues As Double
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set Orders_sh = ThisWorkbook.Sheets("uzsakymai")
Set Template_sh = ThisWorkbook.Sheets("lapukas")
Set setting_Sh = ThisWorkbook.Sheets("Settings")
Application.DisplayStatusBar = True
Application.StatusBar = ""
Dim lngI As Long
Dim File_Name As String
'At this point, the Orders_sh worksheet should already have its fields properly sorted/ordered. (Name, then Size)
lngI = 2
Application.StatusBar = lngI - 1 & "/" & Orders_sh.Range("A11").End(xlUp).Row - 1 'a maximum of 10 items can be written here!
Set oCell = Orders_sh.Range("A" & lngI) ' the initial cell
Do
strKey_TheName = UCase(Orders_sh.Range("C" & lngI).Value)
lngSumOfItems = 0
dblSumOfValues = 0
Do
Template_sh.Range("D1").Value = Orders_sh.Range("C" & lngI).Value
lngTemplate_A = IIf(lngSumOfItems = 0, 4, Template_sh.Range("A10").End(xlUp).Offset(1, 0).Row)
Template_sh.Range("A" & lngTemplate_A).Value = Orders_sh.Range("B" & lngI).Value
Template_sh.Range("B" & lngTemplate_A).Value = Orders_sh.Range("A" & lngI).Value & " - " & Orders_sh.Range("E" & lngI).Value
Template_sh.Range("P" & lngTemplate_A).Value = Orders_sh.Range("D" & lngI).Value
lngSumOfItems = lngSumOfItems + 1
dblSumOfValues = dblSumOfValues + Orders_sh.Range("D" & lngI).Value
File_Name = lngSumOfItems & "(" & Orders_sh.Range("C" & lngI).Value & "-" & VBA.Round(dblSumOfValues, 0) & ").pdf"
lngI = lngI + 1
Set oCell = oCell.Offset(1, 0)
Loop Until strKey_TheName <> UCase(oCell.Offset(0, 2).Value)
Template_sh.ExportAsFixedFormat xlTypePDF, setting_Sh.Range("F4").Value & "\" & File_Name
Template_sh.Range("D1").Value = ""
Template_sh.Range("A4:P10").ClearContents
Loop Until Len(oCell.Value) = 0
Application.StatusBar = ""
MsgBox "Done"
End Sub

Macro that export complete row data based on column name to new excel file getting error in that

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

R1C1 Notation To Pick Index Range for Index,Match,Match

I cannot seem to get this line of code working:
For Each errCell In BET_ws.Range("E5:E" & lastrow).Offset(0, 1 + i)
errCell.FormulaR1C1 = "=INDEX('" & cNameAndPath & BET_ws.Cells(errCell.Row,
2).Value & "'!R2C3:R1000C200,MATCH(R2C[-1],'" & cNameAndPath &
BET_ws.Cells(errCell.Row, 2).Value & "'!R2C2:R400C2,0),MATCH(RC3,'" & cNameAndPath
& BET_ws.Cells(errCell.Row, 2).Value & "'!R1C3:R1C200,0))"
Next errCell
I keep getting an object undefined error. Is it a problem with my R1C1 notation or is it an issue with BET_ws.Cells(errCell.Row,2).Value statement? In Column B the tab name needed for my INDEX reference is in the RC2 location. Not sure how to correct the issue. cNameAndPath is defined and is pulling the value I want. Another formula is running in the adjacent range with no problem.
Here is most of the code if it helps:
Sub BetConverter()
Dim wbkTarget As Workbook
Dim fNameAndPath As Variant
Dim cNameAndPath As Variant
Dim cFileName As String
Dim cFilePath As String
Dim BET_ws As Worksheet
Dim shtTarget As Worksheet
Dim ws As Worksheet
Dim lrow As Long 'last row variable
Dim lcol As Long 'last column variable
Dim lastrow As Long
Dim i As Integer
Dim cwbTarget As Workbook
Dim errCell As Range
'kill clunky processes
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
'delete summary tab if it exists
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Sheets("BET Consolidated").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'On Error GoTo Errhandler
Sheets.Add(After:=Sheets("Macro")).Name = "BET Consolidated" 'create new tab
Set BET_ws = ThisWorkbook.Sheets("BET Consolidated")
MsgBox ("Please Select the Bid Entry Tool to be Consolidated in the following File Dialog Box.")
fNameAndPath = Application.GetOpenFilename(Title:="Select Bid Entry Tool to be Consolidated")
If fNameAndPath = False Then Exit Sub
Set wbkTarget = Workbooks.Open(fNameAndPath)
MsgBox ("Please Select the MDB for Comparison in the following File Dialog Box.")
cNameAndPath = Application.GetOpenFilename(Title:="Select the MDB for Comparison")
If cNameAndPath = False Then Exit Sub
Set cwbTarget = Workbooks.Open(cNameAndPath)
cFileName = Mid$(cNameAndPath, InStrRev(cNameAndPath, "\") + 1)
cFilePath = Left$(cNameAndPath, InStrRev(cNameAndPath, "\"))
Do While shtTarget Is Nothing
For Each ws In wbkTarget.Sheets
If ws.Name Like "*H*" Then
Set shtTarget = ws
End If
Next ws
Loop
lrow = shtTarget.Cells(Rows.Count, 11).End(xlUp).Row
With shtTarget.Range("K2:K" & lrow)
BET_ws.Range("A1").Resize(.Rows.Count, .Columns.Count) = .Value
End With
With shtTarget.Range("J2:J" & lrow)
BET_ws.Range("B1").Resize(.Rows.Count, .Columns.Count) = .Value
End With
With shtTarget.Range("O2:O" & lrow)
BET_ws.Range("C1").Resize(.Rows.Count, .Columns.Count) = .Value
End With
With shtTarget.Range("P2:P" & lrow)
BET_ws.Range("D1").Resize(.Rows.Count, .Columns.Count) = .Value
End With
i = 0
For Each ws In wbkTarget.Worksheets
If ws.Name Like "*H*" Then
Set shtTarget = ws
lastrow = shtTarget.Cells(shtTarget.Rows.Count, 27).End(xlUp).Row
With shtTarget.Range("AA1:AA" & lastrow)
BET_ws.Range(Range("D1").Offset(0, 1 + i).Address).Resize(.Rows.Count, .Columns.Count) = .Value
End With
For Each errCell In BET_ws.Range("E5:E" & lastrow).Offset(0, 1 + i)
errCell.FormulaR1C1 = "=INDEX('" & cNameAndPath & BET_ws.Cells(errCell.Row, 2).Value & "'!R2C3:R1000C200,MATCH(R2C[-1],'" & cNameAndPath & BET_ws.Cells(errCell.Row, 2).Value & "'!R2C2:R400C2,0),MATCH(RC3,'" & cNameAndPath & BET_ws.Cells(errCell.Row, 2).Value & "'!R1C3:R1C200,0))"
Next errCell
For Each errCell In BET_ws.Range("F5:F" & lastrow).Offset(0, 1 + i)
errCell.FormulaR1C1 = "=IF(RC[-2]=RC[-1],""MATCH"",""DOES NOT MATCH"")"
Next errCell
i = i + 3
End If
Next ws
Also tried like this:
For Each errCell In BET_ws.Range("E5:E" & lastrow).Offset(0, 1 + i)
tName = BET_ws.Cells(errCell.Row, 2).Value
errCell.FormulaR1C1 = "=INDEX('" & cFilePath & "[" & cFileName & "]" & tName & "'!R2C3:R1000C200,MATCH(R2C[-1],'" & cFilePath & "[" & cFileName & "]" & tName & "'!R2C2:R400C2,0),MATCH(RC3,'" & cFilePath & "[" & cFileName & "]" & tName & "'!R1C3:R1C200,0))"
Next errCell

Finding Duplicates & Putting them in Master Folder

My code renames folders based on what is in first column:
Dim sFolder As String
Option Explicit
Sub addPrefix()
Dim strfile As String
Dim filenum As String
Dim strOldDirName
Dim strNewDirName
strfile = Dir(sFolder)
Dim old_name, new_name As String
Dim i As Long
With ThisWorkbook.Worksheets("data")
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
strOldDirName = sFolder & ThisWorkbook.Worksheets("data").Cells(i, 2).Value
strNewDirName = sFolder & ThisWorkbook.Worksheets("data").Cells(i, 1).Value & " " & ThisWorkbook.Worksheets("data").Cells(i, 2).Value
Name strOldDirName As strNewDirName
Next i
End With
End Sub
and then I check for duplicates on Column C (email column). If they are a duplicate I move them to their 'master' folder (which is just the first of the duplicates found). Upon this, it adds the suffix ' - MASTER' on to the folder.
Here is the code to move duplicates:
Sub moveDuplicates()
' This will find duplicates and move them into a master folder. It'll will then delete the row
Dim masterID
Dim masterPlatform
Dim objFileSystem
Dim FromPath As String
Dim ToPath As String
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
Dim masterOldFolderName
Dim masterNewFolderName
Dim masterSuffix
Dim LastRow As Long, i As Long
Dim rngWhole As Range, rngSplit As Range
masterID = 0
masterPlatform = 0
masterSuffix = " - MASTER"
masterOldFolderName = ""
masterNewFolderName = ""
With ThisWorkbook.Worksheets("data")
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
Set rngWhole = .Range("C1:C" & LastRow)
.Range("E" & 1).Value = rngWhole
For i = 1 To LastRow
If WorksheetFunction.CountIf(rngWhole, .Range("C" & i).Value) > 1 Then
Set rngSplit = .Range("C1:C" & i)
If WorksheetFunction.CountIf(rngSplit, .Range("C" & i).Value) = 1 Then
masterID = .Range("B" & i).Value
masterPlatform = .Range("A" & i).Value
'' Renme master folders with subfix of "- MASTER"
masterOldFolderName = sFolder & masterPlatform & " " & masterID
masterNewFolderName = sFolder & masterPlatform & " " & masterID & masterSuffix
Name masterOldFolderName As masterNewFolderName
'' End of renaming
'.Range("D" & i).Value = "MASTER " & masterID
Else
'.Range("D" & i).Value = "CHILD " & masterID & " This folder: " & .Range("B" & i).Value
'MOVING FOLDER
FromPath = sFolder & .Range("A" & i).Value & " " & .Range("B" & i).Value '<< Change
ToPath = sFolder & masterPlatform & " " & masterID & masterSuffix & "\" '<< needs the slash to go into the folder
.Range("H" & i).Value = "From: " & FromPath
.Range("I" & i).Value = "From: " & ToPath
'Check if source and target folder exists
If objFileSystem.FolderExists(FromPath) = True And objFileSystem.FolderExists(ToPath) = True Then
objFileSystem.MoveFolder Source:=FromPath, Destination:=ToPath
lblStatus.Caption = "Moving " & FromPath & " To " & ToPath
Rows(i).EntireRow.Delete
lblStatus.Caption = " Deleting " & .Range("A" & i).Value & " " & .Range("B" & i).Value
'MsgBox "Source folder has moved to target folder"
Else
'MsgBox "Either source or target folder does not exist"
End If
' END OF MOVING FOLDER
' ROW GETS DELETED
End If
'.Range("C" & i).Interior.ColorIndex = 3
End If
Next i
End With
End Sub
My script works to a certain degree:
But it just puts everything into the first 'MASTER' folder
Here is my sheet:
I then call this from a button:
' Open the select folder prompt
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then ' if OK is pressed
sFolder = .SelectedItems(1) & "\"
End If
End With
If sFolder <> "" Then ' if a file was chosen
Me.txtFolderPath.Text = sFolder
'' calls functions
addPrefix
moveDuplicates
Sheet_SaveAs ' saves output
end sub
Is the reason it is not performing as expected due to I am calling it wrongly?
Full code: https://www.dropbox.com/s/k06b5hydc4v7bpn/so-files.zip?dl=0
(code can be run from developer> forms> userform1)
DEBUGGING:
I think the problem seems to arise here when debugging:
'' Renme master folders with subfix of "- MASTER"
masterOldFolderName = sFolder & masterPlatform & " " & masterID
masterNewFolderName = sFolder & masterPlatform & " " & masterID & masterSuffix
Name masterOldFolderName As masterNewFolderName
'' End of renaming
I am not sure if this is because it is in the wrong place (which I assume)

VBA Excel - Application or object oriented error with =HYPERLINK

I have a problem with a VBA-based hyperlink in Excel 2016. I want to add a "Navigation" sheet in front of all other sheets but I have an issue with "=HYPERLINK". My code is the following:
Dim wbBook As workbook
Dim wsActive As Worksheet
Dim wsSheet As Worksheet
Dim lnRow As Long
Dim lnPages As Long
Dim lnCount As Long
Dim temp As Variant
Set wbBook = ActiveWorkbook
wbBook.Sheets.Add(Before:=Worksheets(1)).Name = "Navigation"
Set wsActive = wbBook.ActiveSheet
With wsActive
.Name = "Navigation"
With .Range("A1:A1")
.Value = VBA.Array("Mitarbeiter")
.Font.Bold = True
End With
End With
lnRow = 2
lnCount = 1
For Each wsSheet In wbBook.Worksheets
If wsSheet.Name <> wsActive.Name Then
wsSheet.Activate
With wsActive
Worksheets("Navigation").Cells(lnRow, 1).Formula = _
"=HYPERLINK(" & Chr(34) & "#" & "'" & wsSheet.Name & "'" & "!A" & lnRow & Chr(34) & ";" & Chr(34) & wsSheet.Name & Chr(34) & ")"
End With
lnRow = lnRow + 1
lnCount = lnCount + 1
End If
Next wsSheet
The problem I have is that when I add an "=" in front of HYPERLINK, the error "Anwendungs- oder objektorientierter Fehler" (application or object oriented error) pops up. If I run the macro without the "=", the program works but I manually have to add the equation sign in the navigation sheet.
Cheers in advance!
Since you are already using VBA, why not the VBA capability of Adding Hyperlinks (with .Hyperlinks.Add).
You can read about it more on MSDN
I reduced a the use of ActiveSheet, and Activate.
Code
Option Explicit
Sub TestHyperlink()
Dim wbBook As Workbook
Dim wsActive As Worksheet
Dim wsSheet As Worksheet
Dim lnRow As Long
Dim lnPages As Long
Dim lnCount As Long
Dim temp As Variant
Set wbBook = ActiveWorkbook
Set wsActive = wbBook.Sheets.Add(Before:=Worksheets(1))
With wsActive
.Name = "Navigation"
With .Range("A1:A1")
.Value = VBA.Array("Mitarbeiter")
.Font.Bold = True
End With
End With
lnRow = 2
lnCount = 1
For Each wsSheet In wbBook.Worksheets
If wsSheet.Name <> wsActive.Name Then
With wsSheet
.Hyperlinks.Add Anchor:=Worksheets("Navigation").Range("A" & lnRow), _
Address:="", SubAddress:="'" & .Name & "'!" & .Range("A" & lnRow).Address, _
TextToDisplay:="#" & .Name
End With
lnRow = lnRow + 1
lnCount = lnCount + 1
End If
Next wsSheet
End Sub
Try using a comma to separate the parameters of the formula instead of a semicolon. I think forcing formulae into cells like this ignores localisation.
With wsActive
Worksheets("Navigation").Cells(lnRow, 1).Formula = _
"=HYPERLINK(" & Chr(34) & "#" & "'" & wsSheet.Name & "'" & "!A" & lnRow & Chr(34) & "," & Chr(34) & wsSheet.Name & Chr(34) & ")"
End With

Resources