I keep getting and error message at Set MainRng = Workbooks(mainfile)
It is an object not defined error, this works in my other spreadsheet, but not in the new one.
Sub LoadData(mainfile As String, srcfile As String)
Dim DS As Worksheet
Dim Cell As Range
Dim CurrentRow As Integer, ValPos As Integer
Dim AsFoundLoc As String, AsLeftLoc As String, ValTextLoc As String
Dim SheetName As String, ValDataText As String, FileValidation As String
Dim ImportData As Variant, Multiplier As Variant, AutomationType As String
Dim AsLeftData As Variant
Dim VerifySheetName As String
Workbooks(srcfile).Activate
AutomationType = Workbooks(mainfile).Worksheets("Import Map").Range("B5").Value
SheetName = Workbooks(mainfile).Worksheets("Import Map").Range("B7").Value
ValDataText = Workbooks(mainfile).Worksheets("Import Map").Range("A10").Value
ValTextLoc = Workbooks(mainfile).Worksheets("Import Map").Range("B10").Value
'Set ValPos to 0
ValPos = 0
AsLeftData = vbNo
'Set the Verify Sheet Name
VerifySheetName = SheetName
'Change Verify Sheet Name for SureCal
'If SureCal Ask if this is As Left Data
If AutomationType = "SureCal" Then
VerifySheetName = "Cover Sheet"
AsLeftData = MsgBox("NOTE: For SureCal the you will need to Import Data for both" & Chr(13) & "the As Found and As Left Data Seperately if required" _
& Chr(13) & Chr(13) & "Are you Importing the Left Data now?", vbYesNo)
End If
'Check to see if a validation text is used
If ValDataText <> "" And ValTextLoc <> "" Then
FileValidation = Workbooks(srcfile).Worksheets(VerifySheetName).Range(ValTextLoc).Value
ValPos = InStr(1, FileValidation, ValDataText, vbTextCompare)
Else
ValPos = 1
End If
'Proceed if File Text Validated
If ValPos <> 0 Then
Application.StatusBar = "Importing Data..."
Set MainRng = Workbooks(mainfile).Worksheets("Import Map").Range("A" & DS_StartRow & ":A" & DS_LastRow)
Workbooks(mainfile).Activate
For Each Cell In MainRng
CurrentRow = Cell.Row
SheetName = Workbooks(mainfile).Worksheets("Import Map").Range("B7").Value
AsFoundLoc = Workbooks(mainfile).Worksheets("Import Map").Range("C" & CurrentRow).Value
AsLeftLoc = Workbooks(mainfile).Worksheets("Import Map").Range("D" & CurrentRow).Value
Multiplier = Workbooks(mainfile).Worksheets("Import Map").Range("E" & CurrentRow).Value
ImportData = ""
'Now add the AsFound data
If AsFoundLoc <> "" Then
ImportData = Workbooks(srcfile).Worksheets(SheetName).Range(AsFoundLoc).Value
'Call the Correct Automation Type to Format Data input
If AutomationType = "SureCal" Then ImportData = SureCalData(ImportData)
If AutomationType = "NI" Then ImportData = NIData(ImportData)
'First line of code moves data to datasheet, 2nd line of code adds it to the Repeatability column
If Not IsEmpty(ImportData) Then
If IsNumeric(ImportData) Or LCase(ImportData) = "pass" Or LCase(ImportData) = "fail" Then
If IsNumeric(ImportData) Then
ImportData = ImportData * Multiplier
End If
If AsLeftData = vbNo Then
Workbooks(mainfile).Worksheets("Datasheet").Range("I" & CurrentRow).Value = ImportData
Workbooks(mainfile).Worksheets("Import Map").Range("F" & CurrentRow).Value = ImportData
Else
Workbooks(mainfile).Worksheets("Datasheet").Range("J" & CurrentRow).Value = ImportData
End If
End If
End If
End If
'Now add the AsLeft data
'Note: As Left is skipped for SureCal Imports
If AutomationType <> "SureCal" Then
If AsLeftLoc <> "" Then
ImportData = ""
ImportData = Workbooks(srcfile).Worksheets(SheetName).Range(AsLeftLoc).Value
'Call the Correct Automation Type to Format Data input - Note: SureCal Does not get Called
'If AutomationType = "SureCal" Then ImportData = SureCalData(ImportData)
If AutomationType = "NI" Then ImportData = NIData(ImportData)
If Not IsEmpty(ImportData) Then
If IsNumeric(ImportData) Or LCase(ImportData) = "pass" Or LCase(ImportData) = "fail" Then
If IsNumeric(ImportData) Then
ImportData = ImportData * Multiplier
End If
Workbooks(mainfile).Worksheets("Datasheet").Range("J" & CurrentRow).Value = ImportData
End If
End If
End If
End If
Next Cell
'Determine Starting of Data in each the main and the source
'Workbooks(srcfile).Activate
'Workbooks(mainfile).Activate
Else
MsgBox "Validation Text ( " & ValDataText & " ) Was not Found in the " & VerifySheetName _
& " at Cell " & ValTextLoc & Chr(13) & Chr(13) & "No Data was Imported"
End If
End Sub
Error 1004 on this line:
Set MainRng = Workbooks(mainfile).Worksheets("Import Map").Range("A" & DS_StartRow & ":A" & DS_LastRow)
Means something is wrong with the parameters given to the Range call (bad arguments for Workbooks or Worksheets would throw error 9 / "subscript out of range").
.Range("A" & DS_StartRow & ":A" & DS_LastRow)
Variables DS_StartRow and DS_LastRow aren't declared or assigned anywhere in the code you posted before this instruction gets to run.
Without Option Explicit and assuming they aren't global variables defined elsewhere, looks like it's safe to assume their value is 0.
.Range("A0:A0")
...is illegal, since worksheet row addresses are 1-based. Hence, error 1004 is thrown.
One way to narrow down on the problem, is to split such instructions doing too many things, into smaller statements that do one thing:
Dim wb As Workbook
Set wb = Workbooks(mainfile)
Dim ws As Worksheet
Set ws = wb.Worksheets("Import Map")
Dim map As Range
Set map = ws.Range("A" & DS_StartRow & ":A" & DS_LastRow)
Now it's much easier to see exactly which instruction is failing.
Related
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
I would like to say i'm an intermediate user of Excel VBA but i'm struggling with this one.
I have written a script to read a text file and strip out all the information I need and then add it to Worksheet that is named by the text file name and then todays date.
Set WS1 = ActiveWorkbook.Sheets("Home")
myFile = Application.GetOpenFilename()
myFileName = FileNameOf(myFile)
WS1.Copy After:=Sheets(Sheets.Count)
Set WS2 = ActiveSheet
strNewSheetName = myFileName & " - " & Format(Now, "DD-MM-YY")
blnSheetCheck = CheckIfSheetExists(strNewSheetName)
If blnSheetCheck = True Then
blnDeleteSheet = MsgBox("NOTICE:" & vbCrLf & vbCrLf & "This text file has already been added today!!" & vbCrLf & vbCrLf & "would you like to delete the existing one?", vbYesNo + vbCritical)
If blnDeleteSheet = vbYes Then
ActiveWorkbook.Sheets(strNewSheetName).Delete
WS2.Name = strNewSheetName
Else
' Roll the number here
End If
Else
WS2.Name = strNewSheetName
End If
I use this function to check if it exists
Function CheckIfSheetExists(SheetName) As Boolean
CheckIfSheetExists = False
Err.Clear
On Error Resume Next
Set WS99 = Sheets(SheetName)
If Err = 0 Then
CheckIfSheetExists = True
Else
CheckIfSheetExists = False
End If
End Function
When I first wrote the code I was going to add a time to the sheet name but it will sometimes push the name over the 31 character limit.
So I would like some guidance on how I can add a numeric to the end of the sheet name and then repeat the process to see if that sheet name exists and then move it up a number and then check again.
Thank you in advance
Andy
This will name the sheets as, for example:
Test 03-05-18 and then Test 03-05-18_01 up to Test 03-05-18_99.
Update this line to allow more copies:
TempShtName = SheetName & "_" & Format(lCounter, "00")
There's one procedure and two functions in the code:
The first is a copy of your code (with variables declare).
The second figures out the name of the sheet.
The third checks if the sheet exists.
Public Sub Test()
Dim WrkBk As Workbook
Dim WS1 As Worksheet, WS2 As Worksheet
Dim myFile As String
Dim myFileName As String
myFile = Application.GetOpenFilename()
'File name including extension:
'myFileName = Mid(myFile, InStrRev(myFile, "\") + 1)
'File name excluding extension:
myFileName = Mid(myFile, InStrRev(myFile, "\") + 1, InStrRev(myFile, ".") - InStrRev(myFile, "\") - 1)
With ThisWorkbook
Set WS1 = .Sheets("Home")
WS1.Copy After:=.Worksheets(.Worksheets.Count)
Set WS2 = .Worksheets(.Worksheets.Count)
WS2.Name = GetSheetName(myFileName & " - " & Format(Now, "dd-mm-yy"))
End With
End Sub
'Return a numbered sheet name (or the original if it's the first).
Public Function GetSheetName(SheetName As String, Optional WrkBk As Workbook) As String
Dim wrkSht As Worksheet
Dim TempShtName As String
Dim lCounter As Long
If WrkBk Is Nothing Then
Set WrkBk = ThisWorkbook
End If
TempShtName = SheetName
Do While WorkSheetExists(TempShtName)
lCounter = lCounter + 1
TempShtName = SheetName & "_" & Format(lCounter, "00")
Loop
GetSheetName = TempShtName
End Function
'Check if the sheet exists.
Public Function WorkSheetExists(SheetName As String, Optional WrkBk As Workbook) As Boolean
Dim wrkSht As Worksheet
If WrkBk Is Nothing Then
Set WrkBk = ThisWorkbook
End If
On Error Resume Next
Set wrkSht = WrkBk.Worksheets(SheetName)
WorkSheetExists = (Err.Number = 0)
Set wrkSht = Nothing
On Error GoTo 0
End Function
Edit:
To remove illegal characters and keep the sheet name to 31 characters you could add this code in the GetSheetName function just before the TempShtName = SheetName line:
Dim x As Long
Dim sChr As String
Const ILLEGAL_CHR As String = "\/*?:[]"
For x = 1 To Len(SheetName)
sChr = Mid(SheetName, x, 1)
If InStr(ILLEGAL_CHR, sChr) > 0 Then
SheetName = Replace(SheetName, sChr, "_")
End If
Next x
If Len(SheetName) > 28 Then
SheetName = Left(SheetName, 28)
End If
Set WS1 = ActiveWorkbook.Sheets("Home")
myFile = Application.GetOpenFilename()
myFileName = FileNameOf(myFile)
WS1.Copy After:=Sheets(Sheets.Count)
Set WS2 = ActiveSheet
strNewSheetName = myFileName & " - " & Format(Now, "DD-MM-YY")
blnSheetCheck = CheckIfSheetExists(strNewSheetName)
If blnSheetCheck = True Then
blnDeleteSheet = MsgBox("NOTICE:" & vbCrLf & vbCrLf & "This text file has already been added today!!" & vbCrLf & vbCrLf & "would you like to delete the existing one?", vbYesNo + vbCritical)
If blnDeleteSheet = vbYes Then
ActiveWorkbook.Sheets(strNewSheetName).Delete
WS2.Name = strNewSheetName
Else
'======Here's the new bit=================
Dim x as integer
x = 1
Do
strnewsheetname = left(strnewsheetname,30) & x
blnSheetCheck = CheckIfSheetExists(strNewSheetName)
x = x +1
Loop while blnSheetCheck
WS2.Name = strNewSheetName
'=============End of New Bit=============
End If
Else
WS2.Name = strNewSheetName
End If
Technically this will keep looping above 9, but from you've said I don't think this will be a problem
How do you properly construct a VLOOKUP statement in Excel VBA when using the ExecuteExcel4Macro function in VBA?
I have a function that successfully looks up a value in another excel workbook without opening it using ExecuteExcel4Macro, but when I attempt to change the statement to a VLOOKUP statement I get a Run-time error 1004:
The function:
Public Function fGetValueTest(sFilePath, sFileName, sSourceSheet, sSourceCell, vVal, Col)
'Returns the value of a cell from a closed file [BD]
'Declaring variables [BD]
Dim sStringMacro As String
Dim externalValue As Variant
'Setting variables [BD]
externalValue = ExecuteExcel4Macro("'" & sFilePath & "[" & sFileName & "]" & sSourceSheet & "'!" & _
Range("A1").Range(sSourceCell).Address(, , xlR1C1))
'Exception error on file not found [BD]
If Dir(sFilePath & sFileName) = "" Then
fGetValueTest = "File Not Found!"
Exit Function
End If
'If value of source cell is N/A [BD]:
If Application.IsNA(externalValue) Then
'Skip and move on [BD]
fGetValueTest = "0"
ElseIf IsError(externalValue) Then
MsgBox "Error - Check fGetValue Function"
Else
'Creating macro variable [BD]
sStringMacro = "'" & sFilePath & "[" & sFileName & "]" & sSourceSheet & "'!" & _
Range("A1").Range(sSourceCell).Address(, , xlR1C1)
fGetValueTest = ExecuteExcel4Macro("Vlookup(" & vVal & "," & sStringMacro & "," & Col & ",0)")
End If
End Function
And it's usage in the subroutine:
Sub TestGetValue()
Dim sFileName As String
Dim sFilePath As String
Dim sSourceSheet As String
Dim sSourceCell As String
Dim sDestinationCell As String
Dim sDestinationSheet As String
Dim vVal As String
Dim Col As String
sFileName = "0306-0312 Margin Master.xlsx"
sFilePath = "\\store\GroupDrives\Pricing\_Deli_\Deli Fresh Shift\Margin Master\"
sSourceSheet = "Bakery"
sDestinationSheet = "TestSheet"
sSourceCell = "G10"
sDestinationCell = "G10"
vVal = "A10"
Col = 3
ThisWorkbook.Worksheets(sDestinationSheet).Range(sDestinationCell) = fGetValueTest(sFilePath, sFileName, sSourceSheet, sSourceCell, vVal, Col)
End Sub
I don't see any errors in how the VLOOKUP statement is constructed, does ExecuteExcel4Macro require a different type of statement or is there something else going on here?
Any help would be greatly appreciated, and if anyone happens to know if there is a manual for ExecuteExcel4Macro or any documentation of any real value that would also be helpful!
This is a possibility if it can be adopted:
Function:
Public Function GetVlookup(path, file, sheet, ref, Col, vVal)
' Retrieves a value from a closed workbook
Dim arg As String
' Make sure the file exists
If Right(path, 1) <> "\" Then path = path & "\"
If Dir(path & file) = "" Then
GetVlookup = "File Not Found"
Exit Function
End If
If IsNumeric(vVal) Then
vVal = CDbl(vVal)
Else
vVal = Chr(34) & vVal & Chr(34)
End If
' Create the argument
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Address(, , xlR1C1)
' Execute an XLM macro
GetVlookup = ExecuteExcel4Macro("Vlookup(" & vVal & "," _
& arg & "," & Col & ",0)")
End Function
Subroutine:
Sub TestThingSub()
Dim Varr As Variant
Varr = GetVlookup("\\store\GroupDrives\Pricing\_Deli_\Deli Fresh Shift\Margin Master\", "0306-0312 Margin Master2.xlsx", "Sheet2", "A1:B26", 2, "HORSE")
MsgBox Varr
End Sub
Afternoon,
I currently have this User Function saved:
Function AlphaNumericOnly(strSource As String) As String
Dim i As Integer
Dim strResult As String
For i = 1 To Len(strSource)
Select Case Asc(Mid(strSource, i, 1))
Case 48 To 57, 65 To 90, 97 To 122: 'include 32 if you want to include space
strResult = strResult & Mid(strSource, i, 1)
End Select
Next
AlphaNumericOnly = strResult
End Function
I call this User Function in some macros that I run (checking that it is open in the macro). The issue I'm having is when I need to share a macro that references this with another user.
I could of course copy the User Function and send that along with a copy of the macro, they could then save it locally and adjust the macro to check their local copy is open. But this seems quite long winded.
Could anybody offer any suggestions? I am wondering if I could somehow embed the User Function in the macro, or store it centrally some how. Some web searching and asking around has drawn a blank on this one.
Thank you.
Please see the complete macro along with the user function at the end:
Option Explicit
Public Const csFORMULA = "=concatenate(""AGSBIS"",IF(I2=0,"""",CONCATENATE(UPPER(AlphaNumericOnly(LEFT(I2,3))),UPPER(AlphaNumericOnly(RIGHT(I2,3))))),IF(O2=0,"""",UPPER(AlphaNumericOnly(SUBSTITUTE(O2,""0"","""")))),IF(R2=0,"""",UPPER(AlphaNumericOnly(SUBSTITUTE(R2,""0"","""")))),IF(W2=0,"""",UPPER(AlphaNumericOnly(SUBSTITUTE(W2,""0"","""")))),IF(AC2=0,"""",AlphaNumericOnly(SUBSTITUTE(AC2,""0"",""""))),IF(AD2=0,"""",SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(AD2,""-"",""X""),""."",""Y""),""0"",""Z"")),IF(AF2=0,"""",SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(AF2,""-"",""X""),""."",""Y""),""0"",""Z"")),IF(AH2=0,"""",SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(AH2,""-"",""X""),""."",""Y""),""0"",""Z"")))"
Sub AgeasBIS()
Dim lr As Long
Dim cl As Range
Dim Rng As Range
Dim mssg As String
Dim WS As Worksheet
Dim SaveToDirectory As String
Dim DateFormat As String
Dim StatementName As String
Dim Organisation As String
Dim ErrorMessage As String
Dim ErrorMessageTitle As String
Dim CompleteMessage As String
Dim CompleteMessageTitle As String
Dim UserFunctionsLocation As String
Dim SaveLocation As String
DateFormat = Format(CStr(Now), "yyyy_mm_dd_hhmmss_")
ErrorMessageTitle = "Invalid Date Format"
ErrorMessage = "There are invalid date value(s) in the following cell(s). Please check these cells."
CompleteMessageTitle = "Statement Preparation"
CompleteMessage = "Statement preparation is complete. Your file has been saved and will be processed as part of the next scheduled upload."
StatementName = "age_bts"
Organisation = "BTS"
' save locations
'*location of the old user function* UserFunctionsLocation = "C:\Users\user.name\AppData\Roaming\Microsoft\AddIns\UserFunctions.xla"
SaveLocation = "S:\MI\gre_cac\statement_feeds\waiting_to_upload\"
Set WS = ActiveSheet
Application.ScreenUpdating = False
Workbooks.Open Filename:=UserFunctionsLocation
'clears any formats from the sheet
With WS
.Cells.ClearFormats
End With
'standardises all fonts
With WS.Cells.Font
.Name = "Calibri"
.Size = 10
.Bold = False
End With
With WS
'cleans all non_printable characters from the data (excluding date columns) & removes "'" & ","
'trims the insurer comments field to ensure it is a maximum of 500 characters
lr = .Range("I" & Rows.Count).End(xlUp).Row
Set Rng = Union(.Range("C2:AA" & lr), .Range("AD2:AO" & lr), .Range("AM2:AM" & lr))
For Each cl In Rng
If cl.Column = 39 Then 'column AM gets Left() truncation as well
cl = Left(WorksheetFunction.Trim(WorksheetFunction.Clean(cl.Value)), 500)
cl = WorksheetFunction.Substitute(cl.Value, "'", "")
cl = WorksheetFunction.Substitute(cl.Value, ",", "")
Else
cl = WorksheetFunction.Trim(WorksheetFunction.Clean(cl.Value))
cl = WorksheetFunction.Substitute(cl.Value, "'", "")
cl = WorksheetFunction.Substitute(cl.Value, ",", "")
End If
Next cl
'format invoice_date, effective_date & spare_date to dd/mm/yyyy
Union(.Range("AB1:AB" & lr), .Range("AC1:AC" & lr), .Range("AP1:AP" & lr)).NumberFormat = "dd/mm/yyyy"
'formats all numerical fields to "0.00"
Union(.Range("AD2:AL" & lr), .Range("AO2:AO" & lr)).NumberFormat = "0.00"
'add the statement name
Range("A2:A" & lr).FormulaR1C1 = StatementName
'add the organisation name
Range("D2:D" & lr).FormulaR1C1 = Organisation
'adds the formula to generate the unique key (from the declared constant)
Range("B2:B" & lr).Formula = csFORMULA
Range("B2:B" & lr) = Range("B2:B" & lr).Value
'auto-fit all columns
With WS
.Columns.AutoFit
End With
'checks that only date values as present in the invoice_date, effective_date & spare_date
Set Rng = Union(.Range("AB2:AB" & lr), .Range("AC2:AC" & lr), .Range("AP2:AP" & lr))
For Each cl In Rng
If Not IsDate(cl.Value) And Not IsEmpty(cl) Then _
mssg = mssg & cl.Address(0, 0) & Space(4)
Next cl
End With
'If non-date values are found display a message box showing the cell locations
If CBool(Len(mssg)) Then
MsgBox (ErrorMessage & Chr(10) & Chr(10) & _
mssg & Chr(10) & Chr(10)), vbCritical, ErrorMessageTitle
'Otherwise display a message that the statement preparation is complete
Else
MsgBox CompleteMessage, , CompleteMessageTitle
End If
'save location for the .csv
SaveToDirectory = SaveLocation
'uses the set dateformat and save lovation
WS.SaveAs SaveToDirectory & DateFormat & StatementName, xlCSV
Set Rng = Nothing
Set WS = Nothing
Application.ScreenUpdating = True
ActiveWorkbook.Close SaveChanges:=False
End Sub
Function AlphaNumericOnly(strSource As String) As String
Dim i As Integer
Dim strResult As String
For i = 1 To Len(strSource)
Select Case Asc(Mid(strSource, i, 1))
Case 48 To 57, 65 To 90, 97 To 122: 'include 32 if you want to include space
strResult = strResult & Mid(strSource, i, 1)
End Select
Next
AlphaNumericOnly = strResult
End Function
Working through the comments:
Try adding a tempValue before the Select Case
Function AlphaNumericOnly(strSource As String) As String
Dim i As Integer
Dim strResult As String
Dim tempValue As Integer
For i = 1 To Len(strSource)
tempValue = Asc(Mid(strSource, i, 1))
Select Case tempValue
Case 48 To 57, 65 To 90, 97 To 122: 'include 32 if you want to include space
strResult = strResult & Mid(strSource, i, 1)
End Select
Next
AlphaNumericOnly = strResult
End Function
Using Regular Expressions offers a shorter more efficient solution then examining each character:
Function AlphaNumericOnly(strIn) As String
Dim objRegex As Object
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Global = True
.ignorecase = True
.Pattern = "[^\w]+"
AlphaNumericOnly = .Replace(strIn, vbNullString)
End With
End Function
Can somebody help me with this code, I am getting a subscript out of range error:
The line after the 'creating the sheets is highlighted in yellow in debugger
'Validation of year
If TextBox_Year.Value = Format(TextBox_Year.Value, "0000") Then
'Creating Process
'Creation of new sheet
Workbooks.Add
ActiveWorkbook.SaveAs FileName:= _
"" & Workbooks("Temperature Charts Sheet Creator").Sheets("MENU").Cells(4, 12).Value & "Data Sheet - " & ComboBox_Month.Value & " " & TextBox_Year.Value & ".xls", FileFormat _
:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
False, CreateBackup:=False
'Creating of the sheets
Windows("Data Sheet - " & ComboBox_Month.Value & " " & TextBox_Year.Value & ".xls").Activate
Sheets("Sheet3").Select
Sheets("Sheet3").Name = "31 " & ComboBox_Month.Value
Sheets("Sheet2").Select
Sheets("Sheet2").Name = "30 " & ComboBox_Month.Value
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "29 " & ComboBox_Month.Value
For i = 28 To 1 Step -1
Sheets.Add
ActiveSheet.Name = i & " " & ComboBox_Month.Value
Next
Suggest the following simplification: capture return value from Workbooks.Add instead of subscripting Windows() afterward, as follows:
Set wkb = Workbooks.Add
wkb.SaveAs ...
wkb.Activate ' instead of Windows(expression).Activate
General Philosophy Advice:
Avoid use Excel's built-ins: ActiveWorkbook, ActiveSheet, and Selection: capture return values, and, favor qualified expressions instead.
Use the built-ins only once and only in outermost macros(subs) and capture at macro start, e.g.
Set wkb = ActiveWorkbook
Set wks = ActiveSheet
Set sel = Selection
During and within macros do not rely on these built-in names, instead capture return values, e.g.
Set wkb = Workbooks.Add 'instead of Workbooks.Add without return value capture
wkb.Activate 'instead of Activeworkbook.Activate
Also, try to use qualified expressions, e.g.
wkb.Sheets("Sheet3").Name = "foo" ' instead of Sheets("Sheet3").Name = "foo"
or
Set newWks = wkb.Sheets.Add
newWks.Name = "bar" 'instead of ActiveSheet.Name = "bar"
Use qualified expressions, e.g.
newWks.Name = "bar" 'instead of `xyz.Select` followed by Selection.Name = "bar"
These methods will work better in general, give less confusing results, will be more robust when refactoring (e.g. moving lines of code around within and between methods) and, will work better across versions of Excel. Selection, for example, changes differently during macro execution from one version of Excel to another.
Also please note that you'll likely find that you don't need to .Activate nearly as much when using more qualified expressions. (This can mean the for the user the screen will flicker less.) Thus the whole line Windows(expression).Activate could simply be eliminated instead of even being replaced by wkb.Activate.
(Also note: I think the .Select statements you show are not contributing and can be omitted.)
(I think that Excel's macro recorder is responsible for promoting this more fragile style of programming using ActiveSheet, ActiveWorkbook, Selection, and Select so much; this style leaves a lot of room for improvement.)
Subscript out of Range error occurs when you try to reference an Index for a collection that is invalid.
Most likely, the index in Windows does not actually include .xls. The index for the window should be the same as the name of the workbook displayed in the title bar of Excel.
As a guess, I would try using this:
Windows("Data Sheet - " & ComboBox_Month.Value & " " & TextBox_Year.Value).Activate
Option Explicit
Private Sub CommandButton1_Click()
Dim mode As String
Dim RecordId As Integer
Dim Resultid As Integer
Dim sourcewb As Workbook
Dim targetwb As Workbook
Dim SourceRowCount As Long
Dim TargetRowCount As Long
Dim SrceFile As String
Dim TrgtFile As String
Dim TitleId As Integer
Dim TestPassCount As Integer
Dim TestFailCount As Integer
Dim myWorkbook1 As Workbook
Dim myWorkbook2 As Workbook
TitleId = 4
Resultid = 0
Dim FileName1, FileName2 As String
Dim Difference As Long
'TestPassCount = 0
'TestFailCount = 0
'Retrieve number of records in the TestData SpreadSheet
Dim TestDataRowCount As Integer
TestDataRowCount = Worksheets("TestData").UsedRange.Rows.Count
If (TestDataRowCount <= 2) Then
MsgBox "No records to validate.Please provide test data in Test Data SpreadSheet"
Else
For RecordId = 3 To TestDataRowCount
RefreshResultSheet
'Source File row count
SrceFile = Worksheets("TestData").Range("D" & RecordId).Value
Set sourcewb = Workbooks.Open(SrceFile)
With sourcewb.Worksheets(1)
SourceRowCount = .Cells(.Rows.Count, "A").End(xlUp).row
sourcewb.Close
End With
'Target File row count
TrgtFile = Worksheets("TestData").Range("E" & RecordId).Value
Set targetwb = Workbooks.Open(TrgtFile)
With targetwb.Worksheets(1)
TargetRowCount = .Cells(.Rows.Count, "A").End(xlUp).row
targetwb.Close
End With
' Set Row Count Result Test data value
TitleId = TitleId + 3
Worksheets("Result").Range("A" & TitleId).Value = Worksheets("TestData").Range("A" & RecordId).Value
'Compare Source and Target Row count
Resultid = TitleId + 1
Worksheets("Result").Range("A" & Resultid).Value = "Source and Target record Count"
If (SourceRowCount = TargetRowCount) Then
Worksheets("Result").Range("B" & Resultid).Value = "Passed"
Worksheets("Result").Range("C" & Resultid).Value = "Source Row Count: " & SourceRowCount & " & " & " Target Row Count: " & TargetRowCount
TestPassCount = TestPassCount + 1
Else
Worksheets("Result").Range("B" & Resultid).Value = "Failed"
Worksheets("Result").Range("C" & Resultid).Value = "Source Row Count: " & SourceRowCount & " & " & " Target Row Count: " & TargetRowCount
TestFailCount = TestFailCount + 1
End If
'For comparison of two files
FileName1 = Worksheets("TestData").Range("D" & RecordId).Value
FileName2 = Worksheets("TestData").Range("E" & RecordId).Value
Set myWorkbook1 = Workbooks.Open(FileName1)
Set myWorkbook2 = Workbooks.Open(FileName2)
Difference = Compare2WorkSheets(myWorkbook1.Worksheets("Sheet1"), myWorkbook2.Worksheets("Sheet1"))
myWorkbook1.Close
myWorkbook2.Close
'MsgBox Difference
'Set Result of data validation in result sheet
Resultid = Resultid + 1
Worksheets("Result").Activate
Worksheets("Result").Range("A" & Resultid).Value = "Data validation of source and target File"
If Difference > 0 Then
Worksheets("Result").Range("B" & Resultid).Value = "Failed"
Worksheets("Result").Range("C" & Resultid).Value = Difference & " cells contains different data!"
TestFailCount = TestFailCount + 1
Else
Worksheets("Result").Range("B" & Resultid).Value = "Passed"
Worksheets("Result").Range("C" & Resultid).Value = Difference & " cells contains different data!"
TestPassCount = TestPassCount + 1
End If
Next RecordId
End If
UpdateTestExecData TestPassCount, TestFailCount
End Sub
Sub RefreshResultSheet()
Worksheets("Result").Activate
Worksheets("Result").Range("B1:B4").Select
Selection.ClearContents
Worksheets("Result").Range("D1:D4").Select
Selection.ClearContents
Worksheets("Result").Range("B1").Value = Worksheets("Instructions").Range("D3").Value
Worksheets("Result").Range("B2").Value = Worksheets("Instructions").Range("D4").Value
Worksheets("Result").Range("B3").Value = Worksheets("Instructions").Range("D6").Value
Worksheets("Result").Range("B4").Value = Worksheets("Instructions").Range("D5").Value
End Sub
Sub UpdateTestExecData(TestPassCount As Integer, TestFailCount As Integer)
Worksheets("Result").Range("D1").Value = TestPassCount + TestFailCount
Worksheets("Result").Range("D2").Value = TestPassCount
Worksheets("Result").Range("D3").Value = TestFailCount
Worksheets("Result").Range("D4").Value = ((TestPassCount / (TestPassCount + TestFailCount)))
End Sub