Copy data from a workbook to an existing workbook - excel

I'm working on Excel for Mac, v16.53, with OS Catalina v10.15.7
I have an Excel workbook called SCRIPT with two sheets.
Sheet 1 has data entry areas and sheet 2 compiles those entries into a pseudo-table. The data in sheet 1 changes with every new person that is interviewed.
The data in sheet 2 is in columns A, B, H, I and J. It is non-contiguous and doesn't always have row 1 populated.
I can copy those five columns to a new csv file called Telesales-Leads-TODAY'S DATE.
The issue is when there already is a Telesales-Leads-TODAY'S DATE file.
The script is supposed to:
If Telesales-Leads-TODAY'S DATE file does not exist:
Start a new one.
Copy/paste the new SCRIPT data and save the Telesales-Leads-TODAY'S DATE file.
If a Telesales-Leads-TODAY'S DATE file does exist:
Copy the new data from the SCRIPT workbook to the first 100% empty column of the Telesales-Leads-TODAY'S DATE file.
Save the file with the same name (Telesales-Leads-TODAY'S DATE) in csv format.
It throws an error AFTER it copies the data from the SCRIPT workbook but BEFORE it has a chance to completely open the Telesales-Leads-TODAY'S DATE file.
I am using the MsgBox to debug.
Sub BackUpScriptData()
Dim strFileName As String
Dim strFileExists As String
Dim finalcolumn As Integer
Dim firstemptycolumn As Integer
Dim csvOpened As Workbook
Dim oneCell As Range
Dim myCSVFileName As String
Dim myWB As Workbook
Dim tempWB As Workbook
Dim rngToSave As Range
Dim col As String
Dim ColumnNumber As Integer
Dim ColumnLetter As String
Dim colstart As String
Dim CellAddress As String
Dim TestChar As String
Dim NumberToLetter As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
On Error GoTo err
strFileName = "/Users/XXXXXXXX/Library/Group Containers/XXXXXXXX.Office/User Content.localized/Startup.localized/Excel/" & "Telesales-Leads-" & VBA.Format(VBA.Now, "mm-dd-yyyy") & ".csv"
strFileExists = Dir(strFileName)
If strFileExists = "" Then
MsgBox strFileName & " ~~~~~~~~doesn't exist"
Set myWB = ThisWorkbook
myCSVFileName = "/Users/XXXXXXXX/Library/Group Containers/XXXXXXXX.Office/User Content.localized/Startup.localized/Excel/" & "Telesales-Leads-" & VBA.Format(VBA.Now, "mm-dd-yyyy") & ".csv"
Set rngToSave = Range("A1:B69,H1:J69")
rngToSave.Copy
Set tempWB = Application.Workbooks.Add(1)
With tempWB
.Sheets(1).Range("A1").PasteSpecial xlPasteValues
.SaveAs FileName:=myCSVFileName, FileFormat:=xlCSV, CreateBackup:=False
.Close
End With
Else
Set myWB = ThisWorkbook
Set rngToSave = Range("A1:B69,H1:J69")
rngToSave.Copy
Set csvOpened = Workbooks.Open(FileName:=strFileName)
MsgBox "csvOpened is " & csvOpened
With csvOpened
Set oneCell = Range("A1")
Do While WorksheetFunction.CountA(oneCell.EntireColumn)
Set oneCell = oneCell.Offset(0, 1)
Loop
MsgBox "oneCell.Column is " & oneCell.Column
End With
CellAddress = Cells(1, ColNum).Address
For i = 2 To Len(CellAddress)
TestChar = Mid(CellAddress, i, 1)
If TestChar = "$" Then Exit For
NumberToLetter = NumberToLetter & Mid(CellAddress, i, 1)
Next i
MsgBox "colstart is " & colstart
With csvOpened
.Sheets(1).Range(colstart & "1").PasteSpecial xlPasteValues
.SaveAs FileName:=myCSVFileName, FileFormat:=xlCSV, CreateBackup:=False
.Close
End With
End If
err: MsgBox "failed to copy."
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

The code is essentially the same for creating a new workbook or updating an existing, the only difference being the column where the data is to be pasted. As this is a csv file then UsedRange is a simple way to determine the last clear column.
Sub BackUpScriptData2()
Const FOLDER = "/Users/XXXXXXXX/Library/Group Containers/XXXXXXXX.Office/" & _
"User Content.localized/Startup.localized/Excel/"
Const PREFIX = "Telesales-Leads-"
Dim wb As Workbook, wbCSV As Workbook
Dim ws As Worksheet, rngToSave As Range
Dim colNum As Long, myCSVFileName As String
myCSVFileName = PREFIX & VBA.Format(VBA.Now, "mm-dd-yyyy") & ".csv"
' check if file exists
If Len(Dir(FOLDER & myCSVFileName)) = 0 Then
' not exists
MsgBox "'" & myCSVFileName & "'" & vbCrLf & _
"does not exist, it will be created", vbInformation, FOLDER
Set wbCSV = Workbooks.Add()
colNum = 1
Else
' exists
Set wbCSV = Workbooks.Open(FOLDER & myCSVFileName)
With wbCSV.Sheets(1).UsedRange
colNum = .Column + .Columns.Count
End With
MsgBox "'" & myCSVFileName & "'" & vbCrLf & _
"exists, it will extended from column " & colNum, vbInformation, FOLDER
End If
' copy and save
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet2")
Set rngToSave = ws.Range("A1:B69,H1:J69")
rngToSave.Copy
With wbCSV
.Sheets(1).Cells(1, colNum).PasteSpecial xlPasteValues
.SaveAs Filename:=FOLDER & myCSVFileName, FileFormat:=xlCSV, CreateBackup:=False
.Close False
End With
MsgBox "File saved to " & myCSVFileName, vbInformation, FOLDER
End Sub

Related

How to import external file with date as name

I wanted to import or copy and paste data from an external file into the current Excel file using VBA. However, the external file contain a date of the previous month in it. For example, the external file name is Report_20221128. Every month, this external file date maybe different and not necessary be 28 of the month.
Here is what I have done so far.
Sub Report_Run()
Dim wb As Workbook
Dim file As Variant
Dim wbrow As Long, wbrow2 As Long, wbrow3 As Long
Day = Application.WorksheetFunction.EoMonth(Now(), "-1")
Set wb = Workbooks("Run Report " & VBA.Format(LDay, "ddmmyyyy") & ".xlsb")
wb.Worksheets("DD").Activate
wbrow3 = Cells(Rows.Count, "A").End(xlUp).Row
file = Dir(Environ("userprofile") & "\Desktop\Reports\Report_" & Format(Date, "yyyymmdd") & ".xlsx")
End Sub
However, the code unable to read on this line
file = Dir(Environ("userprofile") & "\Desktop\Reports\Report_" & Format(Date, "yyyymmdd") & ".xlsx")
Therefore, how should I set the code so that it can read this external file that contain any date of the previous month in it?
Import Worksheet From File Matching a Pattern
Sub ImportLastMonth()
' Constants
Const SRC_PATH_RIGHT As String = "\Desktop\Reports\"
Const SRC_FILE_LEFT As String = "Report_"
Const SRC_FILE_RIGHT As String = ".xlsx"
Const SRC_WORKSHEET_ID As Variant = "Sheet1" ' adjust! Name or Index
' Source Path
Dim sPathLeft As String: sPathLeft = Environ("USERPROFILE")
Dim sPath As String: sPath = sPathLeft & SRC_PATH_RIGHT
Dim sFolderName As String: sFolderName = Dir(sPath, vbDirectory)
If Len(sFolderName) = 0 Then
MsgBox "The path '" & sPath & "' was not found.", vbCritical
Exit Sub
End If
' Source File
Dim sPatternLeft As String: sPatternLeft = SRC_FILE_LEFT _
& Format(CDate(Application.EoMonth(Now, "-1")), "yyyymm")
Dim sPattern As String: sPattern = sPatternLeft & "*" & SRC_FILE_RIGHT
Dim sFileName As String: sFileName = Dir(sPath & sPattern)
If Len(sFileName) = 0 Then
MsgBox "No files matching the pattern '" & sPattern & "' in '" _
& sPath & "' found.", vbCritical
Exit Sub
End If
' Day
Dim DayStart As Long: DayStart = Len(sPatternLeft) + 1
Dim DayNumString As String, DayNum As Long, NewDayNum As Long
Do While Len(sFileName) > 0
DayNumString = Mid(sFileName, DayStart, 2)
If IsNumeric(DayNumString) Then
NewDayNum = CLng(DayNumString)
If NewDayNum > DayNum Then DayNum = NewDayNum
End If
Debug.Print sFileName, DayNumString, NewDayNum, DayNum
sFileName = Dir
Loop
If DayNum = 0 Then
MsgBox "No file found.", vbCritical
Exit Sub
End If
Application.ScreenUpdating = False
' Source
Dim sFilePath As String
sFilePath = sPath & sPatternLeft & Format(DayNum, "0#") & SRC_FILE_RIGHT
Dim swb As Workbook: Set swb = Workbooks.Open(sFilePath, True, True)
Dim sws As Worksheet: Set sws = swb.Sheets(SRC_WORKSHEET_ID)
' Destination
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
' Copy
sws.Copy After:=dwb.Sheets(dwb.Sheets.Count) ' last
swb.Close SaveChanges:=False
Application.ScreenUpdating = True
' Inform.
MsgBox "Last month's final report imported.", vbInformation
End Sub
Using FileSystemObject and Like
Option Explicit
Sub Report_Run()
Dim wb As Workbook, TargetWB As Workbook
Dim DT As Date
Dim wbrow As Long, wbrow2 As Long, wbrow3 As Long
Dim FSO As Object, oFolder As Object, oFile As Object
Set FSO = CreateObject("scripting.filesystemobject")
' > This needs to be the folder you expect to contain your report
Set oFolder = FSO.getfolder("C:\Users\cameron\Documents\")
' > Date is already a VBA function, you have to use a different variable
DT = Application.WorksheetFunction.EoMonth(Date, "-1")
' > I have this set to "ThisWorkbook" as it's fewer things to worry about, but feel free to change this. _
What is LDay? \|/ you don't have this variable declared
Set wb = ThisWorkbook 'workbooks("Run Report " & VBA.Format(LDay, "ddmmyyyy") & ".xlsb")
' > Avoid using activate
wbrow3 = wb.Worksheets("DD").Cells(Rows.Count, "A").End(xlUp).Row
' > Check each file to see if they're from last month
For Each oFile In oFolder.Files
If oFile.Name Like "Report_" & Format(DT, "yyyymm") & "*" & ".xlsb" Then 'Report name with wildcard for day
Set TargetWB = Workbooks.Open(oFile.Path)
Exit For
End If
Next oFile
' > You now have the report book from last month open and saved to "TargetWB"
End Sub

Copy/Paste Visible Cells from Filtered sheet

I have written this code and it has worked until now.
I have put two AutoFilter to pull certain rows. How do I amend the code to copy and paste visible rows?
I tried
Set TempRng = TempSH.Range("A1:DA" & TempSH.Range("B" & TempSH.Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy'
which copies the cells but then I get an error. Object required
Sub LoopThrough()
Dim MyFile As String, Str As String, MyDir As String
Dim sh As Worksheet, MasterRange As Range, TempWB As Workbook, TempSH As Worksheet, TempRng As Range
Dim NewMasterLine As Long
On Error GoTo ErrorHandler
Set sh = ThisWorkbook.Worksheets("Sheet2")
MyDir = "C:\Users\eldri\OneDrive\Desktop\New folder (2)\"
MyFile = Dir(MyDir & "*.xls")
ChDir MyDir
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While MyFile <> ""
'opens excel
Set TempWB = Workbooks.Open(FileName:=MyFile, UpdateLinks:=False,
Password:=CalcPassword(MyFile))
Set TempSH = TempWB.Worksheets(1)
Columns(1).Insert
Range("c2").Copy Range("A4:A10000")
Worksheets("Data").Range("A4").AutoFilter Field:=3, Criteria1:="AMS"
Worksheets("Data").Range("A4").AutoFilter Field:=4, Criteria1:="XNE"
Set TempRng = TempSH.Range("A1:DA" & TempSH.Range("B" & TempSH.Rows.Count).End(xlUp).Row)
NewMasterLine = sh.Range("B" & sh.Rows.Count).End(xlUp).Row
If NewMasterLine > 1 Then NewMasterLine = NewMasterLine + 1
Set MasterRange = sh.Range("A" & NewMasterLine & ":CW" & (NewMasterLine + TempRng.Rows.Count))
MasterRange.Value = TempRng.Value
'Debug.Print "Imported File: " & MyFile & ", Imported Range: " & TempRng.Address & ", Destination Range: " & MasterRange.Address
TempWB.Close savechanges:=False
MyFile = Dir()
Loop
MsgBox ("Done")
ErrorHandler:
If Err.Number <> 0 Then MsgBox "An error occurred." & vbNewLine & vbNewLine & "Last file that was attempted to be opened: " & MyFile & vbNewLine & vbNewLine & Err.Description
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
You cannot use Set and .Copy in one line.
First you need to set your range of visible cells:
Set TempRng = TempSH.Range("A1:DA" & TempSH.Range("B" & TempSH.Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
Then you need to test if there were visible cells found and if so you can copy them:
If Not TempRng Is Nothing Then
TempRng.Copy
'all code that relies on the copied range `TempRng` needs to go here
Else
MsgBox "No visible cells found!"
End If
I rewrote the code with the advice from #PEH and it worked - Please find the new code below.
Sub LoopThrough()
Dim MyFile As String, Str As String, MyDir As String
Dim sh As Worksheet, MasterRange As Range, TempWB As Workbook, TempSH As Worksheet, TempRng As Range, TempRow As Range
Dim NewMasterLine As Long
On Error GoTo ErrorHandler
Set sh = ThisWorkbook.Worksheets("Sheet2")
' Change address to suite
MyDir = "C:\Users\eldri\OneDrive\Desktop\W220Q1\"
MyFile = Dir(MyDir & "*.xls")
ChDir MyDir
' The following lines will put excel in a state similar to "frozen" mode. This will increase the code performance, as CPU will solely focus on performing
' the operations required by the code and not on showing the changes happening on excel
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Here starts the loop related to the files in folder
Do While MyFile <> ""
'TempWB is a Worksheet object - will be the importing worksheet. TempRng is the used range in sheet 1 of the workbook
Set TempWB = Workbooks.Open(FileName:=MyFile, UpdateLinks:=False, Password:=CalcPassword(MyFile))
Columns(1).Insert
Range("c2").Copy Range("A4:A10000")
Set TempSH = TempWB.Worksheets(1)
Set TempRng = TempSH.Range("A1:DA" & TempSH.Range("A" & TempSH.Rows.Count).End(xlUp).Row)
'NewMasterLine is the last used row (+1) of the Master Workbook (It is basically where the new rows wiill start to be imported)
NewMasterLine = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
If NewMasterLine > 1 Then NewMasterLine = NewMasterLine + 1
'This will loop through all the rows of the range to be imported, checking the first column.
' If the value in the second column is work-xne-ams, will import the single row in the master worklbook
For Each TempRow In TempRng.Rows
If TempRow.Cells(1, 3).Value = "AMS" And TempRow.Cells(1, 4).Value = "XNE" Or TempRow.Row < 4 Then
Set MasterRange = sh.Range("A" & NewMasterLine & ":CW" & NewMasterLine)
MasterRange.Value = TempRow.Value
NewMasterLine = NewMasterLine + 1
End If
Next
TempWB.Close savechanges:=False
MyFile = Dir()
Loop
MsgBox ("Done")
ErrorHandler:
If Err.Number <> 0 Then MsgBox "An error occurred." & vbNewLine & vbNewLine & "Last file that was attempted to be opened: " & MyFile & vbNewLine & vbNewLine & Err.Description
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Function CalcPassword(FileName As String) As String
CalcPassword = ""
On Error Resume Next
Dim TheFile As String: TheFile = Split(Split(FileName, "\")(UBound(Split(FileName, "\"))), ".")(0)
Dim PWD As Range: Set PWD = ThisWorkbook.Worksheets("PWD").ListObjects("PWD").DataBodyRange
CalcPassword = WorksheetFunction.VLookup(TheFile, PWD, 5, False)
End Function

Excel VBA Do While loop in a directory folder and rows count

I have 2 questions with my coding. Please bear with me since I'm not an expert on this.
Ws2.range("B6:Y" & lrow1).copy - doesn't seem to work the way I wanted it to be. It copies cells only from B1:Y6 but the intention is to copy cells starting ffrom B6:Y until the last row.
Dir Do while loops only on one file even though I have multiple files on the specified folder path. Thus, creating an infinite loop.
Any idea on what am I doing wrong?
Private Sub conso()
Dim folder As String, consofolder As String
Dim files As String, consofile As String
Dim dateyear As String, team As String
Dim strfile As String, newdate As String
Dim wb1 As Workbook, wb2 As Workbook
Dim lrow1 As Long, lrow2 As Long
Dim ws1 As Worksheet, ws2 As Worksheet
dateyear = Range("A2").Value
newdate = Format(dateyear, "mmmm yyyy")
team = Range("B2").Value
folder = Range("C2").Value
consofolder = folder & newdate & "\" & team
consofile = "conso "
files = Dir(consofolder & "\*.xlsm")
strfile = consofolder & "\" & consofile & team & " - " & newdate & ".xlsm"
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.AutomationSecurity = msoAutomationSecurityLow
Workbooks.Open Filename:=folder & "\" & "conso conso" & ".xlsm"
Set wb1 = Workbooks("conso conso.xlsm")
wb1.Activate
Set ws1 = wb1.Worksheets("Input")
If Len(Dir(strfile)) = 0 Then
GoTo conso
Else
MsgBox "Conso already in place"
Exit Sub
End If
conso:
Do While files <> ""
Debug.Print files
Workbooks.Open Filename:=consofolder & "\" & files
Set wb2 = Workbooks(files)
Set ws2 = wb2.Worksheets("Input")
With wb2
With Worksheets("Input")
lrow1 = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
End With
ws2.Range("B6:Y" & lrow1).Copy
wb1.Activate
With wb1
With Worksheets("Input")
lrow2 = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
End With
ws1.Range("B" & lrow2).PasteSpecial
wb2.Close
files = Dir(consofolder & "\*.xlsm")
Set wb2 = Nothing
Loop
End Sub

Excel VBA check if sheet exists and if yes add numeric to sheet name

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

Subscript out of range error 9 vba

I am getting a subscript out of range error when another user runs my add in but have no problems when running the same code myself. This happens when setting a workbook value. The filename is being generated by getting the current date and stored as gendate. From this, the filename is created and saved based on the filepath that the user has made. In this example, the value of gv.Range("b2").text is C:\Users\username\Desktop\ReportGeneration. fp is therefore C:\Users\dmulhausen\Desktop\ReportGeneration\TSReports9_6_201615h5m32s.xlsx
This is not generating an error for me, but it is generating an error for another user of the script.
Dim ai As Workbook 'add in data ---Initialized in Report Setup
Dim dwb As Workbook 'destination workbook ---Initialized in Report Setup
Dim ss As Worksheet 'source sheet
Dim ds As Worksheet 'destination sheet or writing sheet
Dim rv As Worksheet 'reporting variables sheet ---Initialized in Report Setup
Dim pv As Worksheet 'ts variables sheet ---Initialized in Report Setup
Dim gv As Worksheet 'global ai variables ---Initialized in Report Setup
Dim tempstr As String
Dim fp As String 'file path ---Initialized in Report Setup
Dim gendate As Date
Dim reportscreated As Integer
Dim initialized As Boolean
Dim sheetnames(1 To 12) As String
Sub reportsetup()
Set ai = Workbooks("TSReports add in.xlam")
Set rv = ai.Worksheets("ReportVars")
Set pv = ai.Worksheets("TS1_2Vars")
Set gv = ai.Worksheets("globalVars")
If (IsEmpty(gv.Range("b2").Value)) Then
MsgBox ("Please select a designated folder for reports")
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
If .SelectedItems.Count > 0 Then
gv.Range("b2").Value = .SelectedItems(1)
End If
ai.Save
End With
End If
initialized = True
gendate = Now()
tempstr = "TSReports" & Month(gendate) & "_" & Day(gendate) & "_" & Year(gendate) & Hour(gendate) & "h" & Minute(gendate) & "m" & Second(gendate) & "s"
fp = gv.Range("b2").Text & "\" & tempstr & ".xlsx"
Workbooks.Add
Application.DisplayAlerts = False
Application.AlertBeforeOverwriting = False
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=fp
Set dwb = Workbooks(tempstr) '*******Error occurs here*******
See: Windows().Activate works on every computer except one
This should fix the issue.
tempstr = "TSReports" & Month(gendate) & "_" & Day(gendate) & "_" & _
Year(gendate) & Hour(gendate) & "h" & Minute(gendate) & "m" & _
Second(gendate) & "s" & ".xlsx"
fp = gv.Range("b2").Text & "\" & tempstr
Workbooks.Add
Application.DisplayAlerts = False
Application.AlertBeforeOverwriting = False
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=fp
Set dwb = Workbooks(tempstr)
However this would be more robust:
Set dwb = Workbooks.Add
Application.DisplayAlerts = False
Application.AlertBeforeOverwriting = False
Application.DisplayAlerts = False
dwb.SaveAs Filename:=fp

Resources