Function call results in type 13 mismatch - excel

So close to completing a large project but cant seem to get past this mismatch. Any help would be appreciated. Hoping this is not too much info...
Getting an .xlsx single sheet file and need to add information to the data in a new book using a cross reference table to get business dates and periods. Here is a sample of the source book:
Sample data snippet
I got this code from #PGSystemTester as a vlookup solution to pull data off of a reference table using a date which would fall between dates in separate columns on the reference table.
Function rngLOOKUP(chkDate As Date, rngf As Range, theColumn As Long) As Variant
Dim acell As Range
For Each acell In rngf.Columns(1).Cells
If acell.Value <= chkDate And acell.Offset(0, 1).Value >= chkDate Then
rngLOOKUP = acell.Offset(0, theColumn - 1).Value
Exit Function
End If
Next acell
rngLOOKUP = "#Nothing"
End Function
I have searched and tried dozens of methods to format the date but cannot get past a type mismatch and am starting to wonder if it is actually the date that is the issue:
Here is a sample of the cross reference table:
Cross reference table sample
Each time I use this call to assign the result to a variable I get a run time error 13, type mismatch:
fYear = rngLOOKUP(aDate, rng, 3)
Here is the complete code. The source file is .xlsx and I format the cell the date comes from before assigning it to a variable.
Sub CleanDaily_Labour()
'
' CleanDaily_Labour Macro
' RMDC Payroll Resarch (MU) Report prep
'
Dim myPath, fName, refFILE, job, JobGR, DateST, WKDay, PDWK, fYear As String
Dim CRef, wkb As Workbook
Dim shtDATE, shtJOB, sht As Worksheet
Dim aDate, fYR As Date
Dim rngLOOKUP As Variant
Dim rng, rngJOBS, rngJBGRP As Range
Dim SC, lastRow, PD, WK As Long
Application.ScreenUpdating = False
myPath = Application.ActiveWorkbook.Path
'
' Get the file date and assign to variables
'
Range("D3").Select
Selection.NumberFormat = "yyyy-mm-dd"
aDate = Range("D3").Value
DateST = WorksheetFunction.Text(aDate, "YYYYMMDD")
WKDay = WorksheetFunction.Text(aDate, "DDD")
Selection.Copy
Range("D7").Select
ActiveSheet.Paste
'
' Rename and save the active workbook by date
' set wkb to new workbook name and assign calendar cross ref
'
fName = myPath & "\Daily_Labour" _
& DateST & ".xlsx"
ActiveWorkbook.SaveAs fName, 51
Set wkb = Workbooks.Open(fName)
Set sht = wkb.Sheets("Sheet1")
refFILE = myPath & "\Cross_Ref_fCalendar.xlsx"
'
' Remove extra header info
'
Rows("1:5").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
'
' Insert Column to the left of Column D
'
Columns("E:G").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromRightOrBelow
'
' Update Headers that will be kept / used
'
Range("A1").Value = "FYear"
Range("E1").Value = "PD_WK"
Range("J1").Value = "JOB_GRP"
Range("F1").Value = "WKDay"
Range("G1").Value = "PD"
Range("H1").Value = "WK"
'
Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
End With
'
' Remove extra columns
'
Sheets("Sheet1").Range("K:K,M:P,R:AY").EntireColumn.Delete
'
' Get the last row and fill known columns
'
lastRow = Cells(Rows.Count, 1).End(xlUp).row
Range("d2:d" & lastRow).Value = aDate
'Range("d2:d" & lastRow).NumberFormat = "dd-mmm-yy" (commented as no impact on error, tried variantions here to overcome mismatch but should not matter as variable never changed here, just the range)
Range("f2:f" & lastRow).Value = WKDay
'
' Set variables for next steps
'
Set CRef = Workbooks.Open(refFILE)
Set shtJOB = CRef.Sheets("JobCross")
Set shtDATE = CRef.Sheets("fcalendar")
sht.Activate
Set rngJOBS = Range("i2:i" & lastRow)
Set rngJBGRP = shtJOB.Range("A1:b16")
Set rng = shtDATE.Range("A2:f210")
'
' Loop through jobs in column i match job in shtJOB
' put matching group in row j (Use Function vLookupVBA)
'
For Each jRow In rngJOBS
jRow.Select
job = ActiveCell.Value
JobGR = VLookupVBA(job, rngJBGRP, Null)
ActiveCell.Offset(0, 1).Value = JobGR
'end for
Next jRow
'
'Save Progress during testing:
'
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs fName, 51
'
' Fill in date parameters from Cross Ref file for Business date
' Use function rngLOOKUP to update variables then set ranges to the variables
' May be more efficient to get row number from cross ref table instead - later.
'
' shtDATE.Activate (does not seem to affect)
'
fYear = rngLOOKUP(aDate, rng, 3) '**This results in the error**
PDWK = rngLOOKUP(aDate, rng, 6)
PD = rngLOOKUP(aDate, rng, 4)
WK = rngLOOKUP(aDate, rng, 5)
'
' Fill the columns with the variables (can likely bypass the variables and put on 1 line)- later
'
Range("A2:A" & lastRow).Value = fYear
Range("E2:E" & lastRow).Value = PDWK
Range("G2:G" & lastRow).Value = PD
Range("H2:H" & lastRow).Value = WK
'
' Cleanup, save and close workbooks
'
Application.DisplayAlerts = False
CRef.Close False
wkb.SaveAs fName, 51
'
' SQL call: Load to existing datbase (GDrive), use same format as Transactions
' ?? Get sales by day? vs maintain PDWK
'
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

rngLOOKUP() expects a Date for its first parameter and a Range for its second parameter. However, you're passing it a Variant in each case. Hence, the type mismatch error. For example, in your code, you've declared aDate as follows...
Dim aDate, fYR As Date
This means that aDate is delcared as a Variant, not a Date, and fYR as a Date. So you'll need to change your delcaration statement as follows...
Dim aDate as Date, fYR As Date
Same thing with rng. And, it looks like the same thing for all your other declaration statements.

Related

Add another filter criteria

How do I add another filter criteria?
So that I can filter by date (like it does) and if comboBox1 value = to what is in column A for each row
The other one I have is filter by date (like it does) and if there is a value in column H for each row
Private Sub CommandButton1_Click()
Dim strStart As String, strEnd As String, strPromptMessage As String
If TextBox1.Value = "" Then
TextBox1.Value = Date
End If
If TextBox2.Value = "" Then
TextBox2.Value = Date
End If
'Prompt the user to input the start date
strStart = TextBox1.Value
'Validate the input string
If Not IsDate(strStart) Then
strPromptMessage = "Oops! It looks like your entry is not a valid " & _
"date. Please retry with a valid date..."
MsgBox strPromptMessage
Exit Sub
End If
'Prompt the user to input the end date
strEnd = TextBox2.Value
'Validate the input string
If Not IsDate(strStart) Then
strPromptMessage = "Oops! It looks like your entry is not a valid " & _
"date. Please retry with a valid date..."
MsgBox strPromptMessage
Exit Sub
End If
'Call the next subroutine, which will do produce the output workbook
Call CreateSubsetWorksheet(strStart, strEnd)
Unload Me
End Sub
Public Sub CreateSubsetWorksheet(StartDate As String, EndDate As String)
Dim wksData As Worksheet, wksTarget As Worksheet
Dim lngLastRow As Long, lngLastCol As Long, lngDateCol As Long
Dim rngFull As Range, rngResult As Range, rngTarget As Range
'Set references up-front
Set wksData = ThisWorkbook.Worksheets("CopyDatabase")
lngDateCol = 5 '<~ we know dates are in column E
'Identify the full data range on Sheet1 (our data sheet) by finding
'the last row and last column
lngLastRow = LastOccupiedRowNum(wksData) '<~ straight from VBA Toolbelt!
'lngLastRow = Cells(Rows.Count, 1).End(xlUp).Row
lngLastCol = LastOccupiedColNum(wksData) '<~ straight from VBA Toolbelt!
'lngLastCol = Cells(1, Columns.Count).End(xlToLeft).Column
With wksData
Set rngFull = .Range(.Cells(3, 1), .Cells(lngLastRow, lngLastCol))
End With
'Apply a filter to the full range we just assigned to get rows
'that are in-between the start and end dates
With rngFull
.AutoFilter Field:=lngDateCol, _
Criteria1:=">=" & StartDate, _
Criteria2:="<=" & EndDate
'If the resulting range contains only 1 row, that means we filtered
'everything out! Check for this situation, catch it and exit
If wksData.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count = 1 Then
MsgBox "Oops! Those dates filter out all data!"
'Clear the autofilter safely and exit sub
wksData.AutoFilterMode = False
If wksData.FilterMode = True Then
wksData.ShowAllData
End If
Exit Sub
Else '<~ otherwise we're all good!
'Assign ONLY the visible cells, which are in the
'date range specified
Set rngResult = .SpecialCells(xlCellTypeVisible)
'clear contents
ThisWorkbook.Sheets("Reports").Range("A3:A" & Range("A3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("B3:B" & Range("B3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("C3:C" & Range("C3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("D3:D" & Range("D3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("E3:E" & Range("E3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("F3:F" & Range("F3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("G3:G" & Range("G3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("H3:H" & Range("H3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("I3:I" & Range("I3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("J3:J" & Range("J3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("K3:K" & Range("K3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("L3:L" & Range("L3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("M3:M" & Range("M3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("N3:N" & Range("N3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("O3:O" & Range("O3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("P3:P" & Range("P3").End(xlDown).Row).ClearContents
ThisWorkbook.Sheets("Reports").Range("Q3:Q" & Range("Q3").End(xlDown).Row).ClearContents
'Create a new Worksheet to copy our data to and set up
'a target Range (for super easy copy / paste)
Set wksTarget = ThisWorkbook.Sheets("Reports")
Set rngTarget = wksTarget.Cells(2, 1)
rngResult.Copy Destination:=rngTarget
End If
End With
'Clear the autofilter safely
wksData.AutoFilterMode = False
If wksData.FilterMode = True Then
wksData.ShowAllData
End If
'Holler at the user, our macro is done!
MsgBox "Data transferred!"
End Sub

Excel VBA will not locate date

I am working to create an add on style sheet to my company timesheet that will autofill company paid holidays by just the user inserting the dates. I use formulas on the excel timesheets to autofill the dates for the entire year so that I save time doing my bi-weekly payroll form. I have a holiday sheet that I name the holidays and input the date they are observed. The code is supposed to search all worksheets in the workbook until it finds the date for the corresponding holiday and input the number of hours off, the holiday code and name. The code I have written will find any date I insert up to 11/9/2022 and after this date it will not find any further dates. I have tried many things including changing the date column format, using different criteria settings for the .Find and even removing the formula from the date column and actually writing in 11/11/2022 and it is still unable to locate the date while using .Find. Please any help would be appreciated. I have added a few screens and code snippets of what I have so far.
Sub VeteransDay()
Dim ws As Worksheet
Dim FindString As String
Dim Rng As Range
FindString = Sheets("Holiday").Range("B9").Value
If Trim(FindString) <> "" Then
For Each ws In Worksheets
If ws.Name <> "Holiday" Then
With ws.UsedRange
Set Rng = .Find(What:=FindString, After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False)
If Not Rng Is Nothing Then
sheetName = ws.Name
Cell_Add = Split(Rng.Address, "$")
ThisCol = Cell_Add(1)
ThisRow = Cell_Add(2)
Worksheets(sheetName).Range("K" & ThisRow).Value = 8
Worksheets(sheetName).Range("K" & ThisRow).Font.Color = vbRed
Worksheets(sheetName).Range("L" & ThisRow).Value = "HD"
Worksheets(sheetName).Range("L" & ThisRow).Font.Color = vbRed
Worksheets(sheetName).Range("M" & ThisRow).Value = Range("A9")
Worksheets(sheetName).Range("M" & ThisRow).Font.Color = vbRed
Exit Sub
End If
End With
End If
Next ws
End If
End Sub
enter image description here
enter image description here
Try this, the search is restricted to the range B1:B37 on each sheet.
Option Explicit
Sub VeteransDay()
Dim ws As Worksheet, ar, r
Dim dt As Date, sName As String, n As Long
Dim arHoliday, lastrow As Long, i As Long
With Sheets("Holiday")
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
arHoliday = .Range("A1:B" & lastrow).Value
End With
For Each ws In Worksheets
If ws.Name <> "Holiday" Then
' loop through holidays
For i = 1 To UBound(arHoliday)
dt = arHoliday(i, 2)
r = Application.Match(CDbl(dt), ws.Range("B1:B37").Value2, 0)
If Not IsError(r) Then
'MsgBox ws.Name & " row " & r
With ws.Range("K" & r)
.Value = 8
.Offset(, 1) = "HD"
.Offset(, 2) = arHoliday(i, 1) ' col A
.Resize(, 3).Font.Color = vbRed
n = n + 1
End With
End If
Next
End If
Next ws
MsgBox n & " found for all dates", vbInformation
End Sub

Auto Filter Array only Filtering by Last Criteria in Array

I am trying to sort a table by deleting rows that have their cell in column 9 NOT beginning with S, X, or P. Below is the code that I have that filters for the rows that do not meet my criteria, and then deletes them, and then shows the remaining values.
Range("I:I").NumberFormat = "#"
lo.Range.AutoFilter Field:=9, Criteria1:=Array("<>S*", "<>X*", "<>P*"), Operator:=xlOr
Application.DisplayAlerts = False
lo.DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
lo.AutoFilter.ShowAllData
Currently, regardless or order, only rows that contain the last criteria in the array are kept.
Delete Multi-Criteria Rows of an Excel Table
You cannot have more than two criteria (elements) with wild characters.
As a workaround, this solution adds a new column and writes a formula to it. The formula returns a boolean indicating whether a string starts with the chars from the list. Then it filters the new column by False and deletes these filtered tables' (not worksheet's) rows. Finally, it deletes the new column.
The data to the right (one empty column is assumed) stays intact, it is not shifted in any way hence the inserting and deleting of a worksheet column instead of using .ListColumns.Add.
Adjust the values in the constants section.
Option Explicit
Sub DeleteMultiCriteriaRows()
Const wsName As String = "Sheet1"
Const tblName As String = "Table1"
Const NotFirstCharList As String = "s,x,p"
Const CritCol As Long = 9
' Extract chars for the formula.
Dim Nfc() As String: Nfc = Split(NotFirstCharList, ",")
Dim NotFirstChar As String: NotFirstChar = "{"
Dim n As Long
For n = 0 To UBound(Nfc)
NotFirstChar = NotFirstChar & """" & Nfc(n) & ""","
Next n
NotFirstChar = Left(NotFirstChar, Len(NotFirstChar) - 1) & "}"
Erase Nfc
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim tbl As ListObject: Set tbl = ws.ListObjects(tblName)
Application.ScreenUpdating = False
With tbl
If Not .ShowAutoFilter Then .ShowAutoFilter = True
If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData ' remove filter
.ListColumns(CritCol).DataBodyRange.NumberFormat = "#" ' ?
Dim nFormula As String
nFormula = "=ISNUMBER(MATCH(LEFT(" & .Name & "[#" _
& .ListColumns(CritCol).Name & "],1)," & NotFirstChar & ",0))"
Dim LastCol As Long: LastCol = .ListColumns.Count
With .ListColumns(1) ' write formulas to newly inserted column
.Range.Offset(, LastCol).EntireColumn.Insert
.DataBodyRange.Offset(, LastCol).Formula = nFormula
End With
LastCol = LastCol + 1 ' think new column
.Range.AutoFilter LastCol, False ' think Not(FirstChar)
Dim vrg As Range ' Visible Range
On Error Resume Next ' prevent 'No cells found...' error
Set vrg = .DataBodyRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
.AutoFilter.ShowAllData ' remove filter
If Not vrg Is Nothing Then ' delete visible rows
vrg.Delete Shift:=xlShiftUp
End If
.ListColumns(LastCol).Range.EntireColumn.Delete ' delete new column
End With
Application.ScreenUpdating = True
End Sub
This code will delete any rows that have a value in the 9th column of the first table on the first sheet in a workbook that doesn't start with one of the letters in arrBeginsWith.
There are other ways to do achieve what you want, for example adding a helper column that identifies the rows to delete with a formula and then filtering on that column.
Option Explicit
Sub KeepRowsStartingWith()
Dim tbl As ListObject
Dim rngDelete As Range
Dim arrBeginsWith As Variant
Dim arrData As Variant
Dim idxRow As Long
Dim StartRow As Long
Dim Res As Variant
Set tbl = Sheets(1).ListObjects(1)
With tbl.ListColumns(9).DataBodyRange
StartRow = .Cells(1, 1).Row
arrData = .Value
End With
ReDim arrDeleteRows(1 To UBound(arrData, 1))
arrBeginsWith = Array("S", "X", "P")
For idxRow = 1 To UBound(arrData, 1)
Res = Application.Match(Left(arrData(idxRow, 1), 1), arrBeginsWith, 0)
If IsError(Res) Then
If rngDelete Is Nothing Then
Set rngDelete = Intersect(tbl.DataBodyRange, Sheets(1).Rows(idxRow + StartRow - 1))
Else
Set rngDelete = Union(rngDelete, Intersect(tbl.DataBodyRange, Sheets(1).Rows(idxRow + StartRow - 1)))
End If
End If
Next idxRow
rngDelete.Delete xlShiftUp
End Sub
I ended up creating a new column in my table with an if statement to identify if a cell began with a letter or number. Then I filtered for the rows that had a number, deleted those rows, and then showed the remaining rows. I then deleted the helper column as to not have to deal with it later.
ThisWorkbook.Worksheets("Aluminum Futures").Columns("T:T").Select
Selection.Insert Shift:=xlToRight
Range("T1") = "Letter/Number"
Range("T2").Select
ActiveCell.FormulaR1C1 = "=IF(ISERR(LEFT(RC[-11],1)*1),""letter"",""number"")"
Range("T2").Select
Selection.AutoFill Destination:=Range("PF[Letter/Number]")
Range("PF[Letter/Number]").Select
lo.Range.AutoFilter Field:=20, Criteria1:="number"
Application.DisplayAlerts = False
lo.DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
lo.AutoFilter.ShowAllData
Columns("T:T").Delete

Text To Column with Comma Loop Generating Error when run, but not in debug

I am attempting to loop through data in a sheet and split them on a comma, when I run the script I get a Run Time Error '1004' Application-Defined or Object defined error.
However, When I step into the script to debug and run it step by step it works perfectly. I was wondering if anyone has seen this and could help me in fixing it.
Sub PopulatePayrollForm()
Dim s As String: s = "Payout Review"
If DoesSheetExists(s) Then
Dim BottomRow As Long
Dim c As Range
Dim splitv() As String
Sheets("Pay Form").Range("A6:AR1000").ClearContents
'Copy to another sheet, Split Columns, Copy and paste full name into 2 cells
Worksheets("Payout Review").Range("A2:A1000").Copy Worksheets("Pay Form").Range("AQ6:AQ1006")
BottomRow = Worksheets("Pay Form").Cells(Rows.Count, "AQ").End(xlUp).Row
Worksheets("Pay Form").Range("AQ6:AQ" & BottomRow).Activate
For Each c In Selection
splitv = Split(c.Value, ",")
If UBound(splitv) > 0 Then
c.Offset(0, -1).Value = splitv(1)
c.Offset(0, -1).Value = c.Offset(0, -1).Value
c.Value = splitv(0)
End If
Next c
Worksheets("Pay Form").Range("AP6:AQ" & BottomRow).Copy Worksheets("Pay Form").Range("C6:C" & BottomRow)
Worksheets("Pay Form").Range("AP6:AQ" & BottomRow).Clear
'Copy and paste Employee Id, Payout AMount, Date Range
Worksheets("Payout Review").Range("B2:B1000").Copy Worksheets("Pay Form").Range("A6:A" & BottomRow)
Worksheets("Payout Review").Range("AB2:AB1000").Copy
Sheets("Pay Form").Range("B6:B" & BottomRow).PasteSpecial xlPasteValues
Worksheets("Payout Review").Range("AD1").Copy Worksheets("Pay Form").Range("J6:J" & BottomRow)
Worksheets("Payout Review").Range("AE1").Copy Worksheets("Pay Form").Range("K6:K" & BottomRow)
Sheets("Pay Form").Visible = True
Else
MsgBox "Data Does not exist"
End If
End Sub
Function DoesSheetExists(sh As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets(sh)
On Error GoTo 0
If Not ws Is Nothing Then DoesSheetExists = True
End Function
The problem is the use of Selection (and Activate):
For Each c In Selection
Just use the Range in question:
For Each c In Worksheets("Pay Form").Range("AQ6:AQ" & BottomRow)
I recommend reading this for a comprehensive discussion of how to avoid Select.

Use stored value to call or create & call sheet

I have a workbook that creates other workbooks and shifts data to them based on the value in column one. Afterwords I need the workbook to store the data it has just copied in a sheet of the same name as the stored variable (in the next empty row), or create the tab if it does not exist.
However i'm having an issue pasting into the tab with the name of the variable, and no idea how to create a new sheet if the variable does not already exist as a sheet.
It's the With Worksheets(SupID).Range("A" & LastRow(SupID) + 1).Paste i'm having trouble with.
Current code below. Thanks!
Private Sub CopyItOver()
Dim myVal As String
Dim SupID As String
'Store Supplier ID
SupID = Trim(Sheets("Raw Data").Range("A2").Value)
'Create workbook
Set newbook = Workbooks.Add
'Copy Records
Set myRng = Workbooks("Book1.xlsm").Worksheets("Raw Data").Range("B2:X7")
myRng.Copy
newbook.Worksheets("Sheet1").Range("A2").PasteSpecial (xlPasteValues)
'Create Header
newbook.Worksheets("Sheet1").Range("A1").Value = "ZHF"
newbook.Worksheets("Sheet1").Range("B1").Value = "CTO"
newbook.Worksheets("Sheet1").Range("C1").Value = "RET"
newbook.Worksheets("Sheet1").Range("D1").Value = SupID
newbook.Worksheets("Sheet1").Range("E1").Value = "RET"
newbook.Worksheets("Sheet1").Range("F1").Value = "RET"
newbook.Worksheets("Sheet1").Range("G1").Value = "6"
newbook.Worksheets("Sheet1").Range("H1").Value = "PROD"
newbook.Worksheets("Sheet1").Range("J1").Value = newbook.Worksheets("Sheet1").Range("B1").Value _
& newbook.Worksheets("Sheet1").Range("D1").Value & "TEMPNUMBER"
newbook.Worksheets("Sheet1").Range("I1").Value = newbook.Worksheets("Sheet1").Range("J1").Value _
& newbook.Worksheets("Sheet1").Range("C1").Value & ".CSV"
newbook.Worksheets("Sheet1").Range("K1") = Format(Date, "ddmmyyyy")
newbook.Worksheets("Sheet1").Range("L1").Value = "Unknown"
newbook.Worksheets("Sheet1").Range("M1").Value = "1"
LastRow = newbook.Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
'Create Footer
newbook.Worksheets("Sheet1").Range("A" & LastRow + 1).Value = "ZFV"
newbook.Worksheets("Sheet1").Range("B" & LastRow + 1).Value = "BATCH" & "TEMPNUMBER"
newbook.Worksheets("Sheet1").Range("C" & LastRow + 1).Value = WorksheetFunction.CountIf(Sheets("Sheet1").Range("A1:A1000"), "RET")
'Name Sheet
myVal = newbook.Worksheets("Sheet1").Range("J1").Value & "RET"
newbook.Worksheets("Sheet1").Name = myVal
'Copy to relevant matching sheet
With Worksheets(SupID).Range("A" & LastRow(SupID) + 1).Paste
End With
'Save Workbook
NewBook.SaveAs Filename:=NewBook.Worksheets("Sheet1").Range("I1").Value
End Sub
Function DLastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
The error's occurring because Worksheets(SupID).Range("A" & LastRow(SupID) + 1).Paste is trying to find that worksheet on your active book, ie the new book. You'd need either to Activate your raw data workbook or change the line to ThisWorkbook.Worksheets(SupID).Range("A" & LastRow(SupID) + 1).Paste.
However, it's not great to use (either explicitly or implicitly) Activate, Select or other keystroke style commands in VBA. Given that you're only copying values (and not the worksheet formats) then, you'd probably be better served reading the data into an array of variants and manipulating those. I've adjusted your code to demonstrate this.
There are some other coding aspects that might not be as robust as they could be. I won't list them all but a comparison of this code with yours will help you see them.
Private Sub CopyItOver()
Dim newBook As Workbook
Dim supSheet As Worksheet
Dim v As Variant
Dim supID As String
Dim namePrefix As String
Dim footerCount As Integer
Dim i As Integer
'Store Supplier ID
supID = Trim(ThisWorkbook.Worksheets("Raw Data").Range("A2").value)
namePrefix = "CTO" & supID & "TEMPNUMBER"
'Create workbook
Set newBook = Workbooks.Add
'Copy Records
v = rawDataSheet.Range("B2:X7").value
For i = 1 To UBound(v, 1)
If v(i, 1) = "RET" Then footerCount = footerCount + 1
Next
'Write new sheet
With newBook.Worksheets(1)
'Values
.Range("A2").Resize(UBound(v, 1), UBound(v, 2)).value = v
'Header
.Range("A1").Resize(, 13) = Array( _
"ZHF", "CTO", "RET", supID, "RET", "RET", "6", "PROD", _
namePrefix & "RET.CSV", namePrefix, _
Format(Date, "ddmmyyyy"), "Unknown", "1")
'Footer
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 3).value = Array( _
"ZFV", "BATCH TEMPNUMBER", footerCount)
'Name
.Name = namePrefix & "RET"
'Save
.SaveAs Filename:=namePrefix & "RET.CSV"
End With
'Copy to relevant matching sheet
On Error Resume Next
Set supSheet = ThisWorkbook.Worksheets(supID)
On Error Goto 0
If newSheet Is Nothing Then
With ThisWorkbook.Worksheets
Set supSheet = .Add(After:=.Item(.Count))
End With
supSheet.Name = supID
End If
With supSheet
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(v, 1), UBound(v, 2)).value = v
End With
End Sub
A few things that aren't quite right:
Add Option Explicit at the top of the module and declare your variables.
LastRow will be a Long data type, but you're trying to use it like an array in With Worksheets(SupID).Range("A" & LastRow(SupID) + 1).Paste. Just use LastRow+1.
With Worksheets(SupID).Range("A" & LastRow(SupID) + 1).Paste
End With should probably be Worksheets(SupID).Range("A" & LastRow + 1).Paste, but it will paste myRng - can't see anything else you've copied.
At the start of the code you reference Workbooks("Book1.xlsm"). If this is the workbook that the code is in I'd change it to ThisWorkbook.
SupID looks at Raw Data on whichever workbook is active at the time (you'd don't specify the workbook when initialising that variable).
This function will return TRUE/FALSE if a named worksheet exists:
Public Function WorkSheetExists(SheetName As String) As Boolean
Dim wrkSht As Worksheet
On Error Resume Next
Set wrkSht = ThisWorkbook.Worksheets(SheetName)
WorkSheetExists = (Err.Number = 0)
Set wrkSht = Nothing
On Error GoTo 0
End Function
Hope that points you in the right direction :)
Edit:
Just noticed to....
Rather than write:
newbook.Worksheets("Sheet1").Range("A1").Value = "ZHF"
newbook.Worksheets("Sheet1").Range("B1").Value = "CTO"
newbook.Worksheets("Sheet1").Range("C1").Value = "RET"
newbook.Worksheets("Sheet1").Range("D1").Value = SupID
newbook.Worksheets("Sheet1").Range("E1").Value = "RET"
newbook.Worksheets("Sheet1").Range("F1").Value = "RET"
newbook.Worksheets("Sheet1").Range("G1").Value = "6"
newbook.Worksheets("Sheet1").Range("H1").Value = "PROD"
You can just use:
newbook.Worksheets("Sheet1").Range("A1:H1") = Array("ZHF", "CTO", "RET", "SupID", "RET", "RET", "6", "Prod")
I managed to resolve my issue using help from Here, to which I adapted to the code below and ran in a separate module, which allows for the use of a previously unspecified sheet name, that is later derived from a cell value. If the sheet does not exist, it is created matching the name to the stored value and the data pasted into it. Thanks for the support!
Sub TEST()
Dim i As Integer, blnFound As Boolean
blnFound = False
SupID = Trim(Sheets("Raw Data").Range("A2").Value)
Set myRng = Workbooks("Book1.xlsm").Worksheets("Raw Data").Range("B2:X7")
myRng.Copy
With ThisWorkbook
For i = 1 To .Sheets.Count
If .Sheets(i).Name = SupID Then
blnFound = True
.Sheets(i).Activate
ActiveSheet.Paste Destination:=Range("A" & LastRow + 1)
Exit For
End If
Next i
If blnFound = False Then
.Sheets.Add
With ActiveSheet
.Name = SupID
ActiveSheet.Paste Destination:=Range("A" & LastRow + 1)
End With
End If
End With
End Sub

Resources