How to populate data from .txt file into Excel in VBA? - excel

I'm trying to create something to read data from a .txt file, then populate data into .xls, but after open the .txt file, how do I get the data out? Basically I'm trying to get the the third column of the lines dated '04/06/2010'. After I open the .txt file, when I use ActiveSheet.Cells(row, col), the ActiveSheet is not pointing to .txt file.
My .txt file is like this (space delimited):
04/05/10 23 29226
04/05/10 24 26942
04/06/10 1 23166
04/06/10 2 22072
04/06/10 3 21583
04/06/10 4 21390
Here is the code I have:
Dim BidDate As Date
BidDate = '4/6/2010'
Workbooks.OpenText Filename:=ForecastFile, StartRow:=1, DataType:=xlDelimited, Space:=True
If Err.Number = 1004 Then
MsgBox ("The forecast file " & ForecastFile & " was not found.")
Exit Sub
End If
On Error GoTo 0
Dim row As Integer, col As Integer
row = 1
col = 1
cell_value = activeSheet.Cells(row, col)
MsgBox ("the cell_value=" & cell_value)
Do While (cell_value <> BidDate) And (cell_value <> "")
row = row + 1
cell_value = activeSheet.Cells(row, col)
' MsgBox ("the value is " & cell_value)
Loop
If cell_value = "" Then
MsgBox ("A load forecast for " & BidDate & " was not found in your current load forecast file titled '" + ForecastFile + ". " + "Make sure you have a load forecast for the current bid date and then open this spreadsheet again.")
ActiveWindow.Close
Exit Sub
End If
Can anyone point out where it goes wrong here?

In the example below, I set the variable ws equal to the sheet I want and I'm able to use that variable to refer to the sheet later. The keyword ActiveWorkbook should point to the newly opened text file. I could tell what you wanted to do with the info, such I just made some stuff up.
Sub GetBidData()
Dim dtBid As Date
Dim ws As Worksheet
Dim rFound As Range
Dim sFile As String
dtBid = #4/6/2010#
sFile = Environ("USERPROFILE") & "\My Documents\ForecastFile.txt"
Workbooks.OpenText Filename:=sFile, _
StartRow:=1, _
DataType:=xlDelimited, _
Space:=True
Set ws = ActiveWorkbook.Sheets(1)
Set rFound = ws.Columns(1).Find( _
Format(dtBid, ws.Range("A1").NumberFormat), , xlValues, xlWhole)
If Not rFound Is Nothing Then
MsgBox rFound.Value & vbCrLf & _
rFound.Offset(0, 1).Value & vbCrLf & _
rFound.Offset(0, 2).Value
End If
End Sub

You should generally avoid using the ActiveWorkbook object unless you're positive that the workbook you want to reference will always be active when your code is run. Instead, you should set the workbook you're working with to a variable. Theoretically, you should be able to use the OpenText method to do this, but VBA doesn't like that. (I'm pretty sure it's a bug.) So right after you open your text file, I would do this:
Workbooks.OpenText Filename:=Forecastfile, StartRow:=1,
DataType:=xlDelimited, Space:=True
Dim ForecastWorkbook As Workbook, book As Workbook
Dim ForecastFileName As String
ForecastFileName = "YourFileNameHere.txt"
For Each book In Application.Workbooks
If book.Name = ForecastFileName Then
Set ForecastWorkbook = book
Exit For
End If
Next book
Then, instead of this...
cell_value = activeSheet.Cells(row, col)
...do this...
cell_value = ForecastWorkbook.Sheets(1).Cells(row, col).Value

Below code will read the text file and paste the values in the cell of Sheet2. However if you put a formatting in the Date column that will do the trick
Public Sub Read_text()
Sheet2.Activate
Set fso = New FileSystemObject
Fname = Application.GetOpenFilename
x = 1
y = 1
Set Stream = fso.OpenTextFile(Fname, ForReading, True)
Do While Not Stream.AtEndOfStream
Str_text = Stream.ReadLine 'Perform your actions
rdtext = Split(Str_text, " ")
Sheet2.Cells(x, y) = rdtext(0)
Sheet2.Cells(x, y + 1) = rdtext(1)
Sheet2.Cells(x, y + 2) = rdtext(2)
x = x + 1
y = 1
Loop
Stream.Close
End Sub
For example : Below code will change the format in '05/04/2010'
Sheet2.Cells(x, y) = Format(rdtext(0), "mm/dd/yyyy;#")

Related

Create subfolders based on cell value and copy images to same folder

I am working on a big project and the ability to change the code stopped at this point. So help is needed please.
The main folders have subfolders and MSR files inside which are related to eachother with the naming.We have to input this main folder path into D4 on our excel file.
The MSR have all the info related to every image. Image folders have all the images inside and we need to sort the all into subfolders.
We already have a macro that retrieves a list on which images are correlated to the correct position. ( see third image)
What we want do now is creating subfolders into the main folder that corresponds to the "*test" in this case and in this new folder there should be subfolders created based on how many unique places there are. In this case it would result in 18 subfolder. The combination of Column D and E are the unique places (first 2 examples = 13200-9496 and 13213-9506). All the image files that corrospond to this place should be put in the new subfolder.
I hope this is somewhat clear?
Main folder overview
Sub folder overview
Output data
Code:
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim WBMacro As Workbook
Set WBMacro = ActiveWorkbook
Dim FoName As Range
Set FoName = WBMacro.Sheets("Instructions").Range("B4")
FolderName = FoName
If Right(FolderName, 1) <> Application.PathSeparator Then FolderName = FolderName & Application.PathSeparator
FName = Dir(FolderName & "*.msr")
'loop through the files
Do While Len(FName)
Dim WBMSR As Workbook
Set WBMSR = Workbooks.Open(FolderName & FName)
With WBMSR
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
'Create new tab to copy data of interest in
Dim WsMSR As Worksheet
Set WsMSR = WBMSR.ActiveSheet
WsMSR.Name = "MSRData"
.Worksheets.Add
Dim wsPictData As Worksheet
Set wsPictData = WBMSR.Sheets("Sheet1")
wsPictData.Name = "PictureInfo"
'Define where to copy data to
Dim RngPictName As Range
Dim RngX As Range
Dim RngY As Range
Set RngPictName = wsPictData.Range("A2")
Set RngXY = wsPictData.Range("B2")
Set RngChipCoX = wsPictData.Range("D2")
Set RngChipCoY = wsPictData.Range("E2")
RngPictName.Offset(-1, 0) = "PictName"
RngXY.Offset(-1, 0) = "DieX,DieY"
RngChipCoX.Offset(-1, 0) = "ChipCoX"
RngChipCoY.Offset(-1, 0) = "ChipCoY"
'Find PictureName
Dim RngPictStart As Range
Dim RngPictStop As Range
Dim RngPict As Range
Dim strImage As String
strImage = "&mp_image_name"
Dim strChipNr As String
strChipNr = "Chip_number"
Dim strChipCo As String
strChipCo = "Chip_coordinate"
With WsMSR.Range("B:B")
Set image = .Find(strImage, lookat:=xlPart, LookIn:=xlValues)
If Not image Is Nothing Then
FirstAddress = image.Address
Do
Set pict = image.Offset(0, 2)
pict.Copy
If RngPictName = "" Then
RngPictName.PasteSpecial
Else
RngPictName.Offset(-1, 0).End(xlDown).Offset(1, 0).PasteSpecial
End If
For i = 1 To 15
'Do
If image.Offset(i, 1).Value = strChipNr Then
Set XY = image.Offset(i, 2)
XY.Copy
If RngXY = "" Then
RngXY.PasteSpecial
Else
RngXY.Offset(-1, 0).End(xlDown).Offset(1, 0).PasteSpecial
End If
End If
If image.Offset(i, 1).Value = strChipCo Then
Set ChipX = image.Offset(i, 2)
ChipX.Copy
If RngChipCoX = "" Then
RngChipCoX.PasteSpecial
Else
RngChipCoX.Offset(-1, 0).End(xlDown).Offset(1, 0).PasteSpecial
End If
Set ChipY = image.Offset(i, 4)
ChipY.Copy
If RngChipCoY = "" Then
RngChipCoY.PasteSpecial
Else
RngChipCoY.Offset(-1, 0).End(xlDown).Offset(1, 0).PasteSpecial
End If
End If
Next
Set image = .FindNext(image)
If image Is Nothing Then
GoTo DoneFinding1
End If
Loop While image.Address <> FirstAddress
End If
End With
DoneFinding1:
End With
' change wsPictData Column B with (x,Y) to 2 columns (B = X, C = Y)
With wsPictData
Columns("B:B").Select
Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
End With
WsMSR.Delete
Dim WBMSRFileName As String
WBMSRFileName = Left(WBMSR.Name, Len(WBMSR.Name) - 4)
Dim relativePath As String
relativePath = WBMSR.Path
WBMSR.SaveAs Filename:=relativePath & "\" & "Pictures_" & WBMSRFileName & ".xlsx", FileFormat:=xlOpenXMLWorkbook
WBMSR.Close (False)
' go to the next file in the folder
FName = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox ("all Files in folder" & relativePath & " are analyzed")
This is a schema to clarify the folder tree. Picture test is the main folder (in this example, name is always different). The grey area on the bottom is wat the macro needs to make. Inside Mainfolder, create for every "test" a new folder with appendix "filtered" and in every folder new folders with the location which hold all the images that were taken on that location.
folder tree
msr file example
This scans the MAIN_FOLDER for excel files starting with Pictures_, opens them and scans down the rows building the destination folder names from columns A, D and E. I put message boxes at each stage so if you single step through you can study how it works. It will create sub-folders if you confirm the action but the actual copy method at the end is commented out. See FileSystemObject for more details.
Sub imagemove()
Const MAIN_FOLDER = "c:\temp\msr\"
Dim FileName As String, wb As Workbook, ws As Worksheet
Dim count As Long, iLastRow As Long, iRow As Long
Dim sPictureFolder As String, sCopyFolder As String
Dim sCopySubFolder As String, msg As String
Dim sPictureName As String, sChipCoX As String, sChipCoY As String
Dim sSrc As String, sDest As String
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
FileName = Dir(MAIN_FOLDER & "Pictures_*.xlsx")
Do While Len(FileName) > 0
' determine picture folder from filename
sPictureFolder = MAIN_FOLDER & Mid(FileName, 10, Len(FileName) - 14)
sCopyFolder = sPictureFolder & "-Filtered"
Debug.Print sPictureFolder, sCopyFolder
' check if folder exists
If FSO.FolderExists(sCopyFolder) = False Then
msg = sCopyFolder & " does not exist, do you want to create it"
If vbYes = MsgBox(msg, vbYesNo, "Confirm") Then
FSO.CreateFolder sCopyFolder
Else
Exit Sub
End If
End If
' scan down msr file
Set wb = Workbooks.Open(MAIN_FOLDER & FileName, False, True)
Set ws = wb.Sheets("PictureInfo")
iLastRow = ws.Cells(Rows.count, 1).End(xlUp).Row
'Debug.Print FileName, iLastRow
For iRow = 2 To iLastRow
sPictureName = ws.Cells(iRow, 1) ' A
sChipCoX = ws.Cells(iRow, 4) ' D
sChipCoY = ws.Cells(iRow, 5) ' E
' ignore jpeg images
If Right(sPictureName, 4) = "jpeg" Then GoTo skip
sCopySubFolder = sCopyFolder & "\" & sChipCoX & "-" & sChipCoY
' check if sub folder exists
If FSO.FolderExists(sCopySubFolder) = False Then
msg = sCopySubFolder & " does not exist, do you want to create it"
If vbYes = MsgBox(msg, vbYesNo, "Confirm") Then
FSO.CreateFolder sCopySubFolder
Else
Exit Sub
End If
End If
' move locations
sSrc = sPictureFolder & "\" & sPictureName
sDest = sCopySubFolder & "\" & sPictureName
' check file exists
If FSO.FileExists(sSrc) = True Then
MsgBox "Copy from " & sSrc & " to " & sDest
'FSO.CopyFile sSrc, sDest
Else
MsgBox sSrc & " does not exist", vbCritical, "File does not exist"
'test FSO.CreateTextFile sDest
End If
Debug.Print "Copy", sSrc, "to", sDest
skip:
Next
count = count + 1
FileName = Dir
Loop
MsgBox count & " Pictures_* files scanned in " & MAIN_FOLDER, vbInformation
End Sub
Ok, I have to answer my question... I deleted all the jpeg files from the Pictures file so these images are not copied so I created another loop. I first had it inside your loop but then it would create an extra extra empty folder. But now I`m afraid that I slowed down the macro by a lot? Is it better to do it inside your loop and then delete the "-" folder in the end?
Set wb = Workbooks.Open(MAIN_FOLDER & "\" & FileName, False, True)
Set ws = wb.Sheets("PictureInfo")
iLastRow = ws.Cells(Rows.count, 1).End(xlUp).Row
'Debug.Print FileName, iLastRow
For iRow = 2 To sLastrow
If Right(ws.Cells(iRow, 1).Text, 4) = "jpeg" Then ws.Cells(iRow, 1).EntireRow.Delete
Next
For iRow = 2 To iLastRow
sPictureName = ws.Cells(iRow, 1) ' A
sChipCoX = ws.Cells(iRow, 4) ' D
sChipCoY = ws.Cells(iRow, 5) ' E
```

Error message of Next without For being recieved

I've written a macro from parent file to change a child file.
The parent file has 10 + rows I want to cycle through.
The child file looks at row1 and creates a file based on the name in row 1.
I am then using a For and Next function to get the child to look at the next row and save the file based on the new name etc etc.
I get an error of:
Next without For
My code:
Sub CreateModels()
' set parameters
Dim vDestPath As String
Dim vDestFile As String
Dim vSrcePath As String
Dim vCurrFile As String
Dim vSrceFile As String
Dim vTot As Integer
vSrceFile = "Bridge 3-S Financial Model.xlsx"
vSrcePath = ActiveWorkbook.Path + "\Bridge 3-S Financial Model.xlsx"
vCurrFile = ActiveWorkbook.Name
vDestPath = ActiveWorkbook.Path & "\Output Models\"
'OpenFinancialModel
Workbooks.Open vSrcePath, UpdateLinks:=False
Sheets("Input Sheet Data").Select
Range("A4").Select
'creating models
For vTot = 6 To 1000
ActiveCell.FormulaR1C1 = "='[Input Sheet.xlsm]Input Sheet'!R" & vTot & "C1"
If Range("A4").Value <> 0 Then
Do
filepath = vDestPath & Range("a4") & ".Xlsx"
ActiveWorkbook.SaveAs (filepath)
vTot = vTot + 1
Next
Else
ActiveWorkbook.Close SaveChanges:=False
End If
End Sub
Remove the "Do" keyword and you might want to end the If statement before the "Next" keyword. Something like this:
For vtot = 6 To 1000
ActiveCell.FormulaR1C1 = "='[Input Sheet.xlsm]Input Sheet'!R" & vtot & "C1"
If Range("A4").Value <> 0 Then
filepath = vDestPath & Range("a4") & ".Xlsx"
ActiveWorkbook.SaveAs (filepath)
vtot = vtot + 1
Else
ActiveWorkbook.Close SaveChanges:=False
End If
Next
You need to improve your loops and queries. Half of the query If .. Then .. Else is within a For.. Next - not a good idea. Please check the position of Next and move to another place for your needs.
And there is an aborted Do missing some pseudo code like:
Dim k As Long
Do While k <= 10
Cells(k, 1).Value = k
Loop
Remove Do and debug your code.

Loop through a range to fill form

I am working on a program that will create coversheets for projects.
All source data is held on the 'data' tab, and using lookups it is populated on the '1034' tab
Cell P2 on sheet '1034' contains the Project#, and after saving that form to PDF, should be set to the next value in the range of projects in 'data'
Below is what I have so far
Sub Generate1034()
'Select Project # Cell, set value to start
Range("P2").Value = Range(Application.Worksheets("Data").Range("A3"))
'Set range on 'data' from A3:(empty cell)
Range (Application.Worksheets("Data").Range("A3").Select)
Do Until IsEmpty(ActiveCell)
'Save Parameters
Application.Worksheets("1034").Range("P2") = Format(x, "000")
Dim SaveName As String
SaveName = ActiveSheet.Range("P33").Text
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ActiveWorkbook.Path & "\1034\" & _
SaveName & ".pdf"\
'Set P2 to the next value in range
Range("P2").Value = Range(Application.Worksheets("Data").Range("A3"))
Loop
End Sub
This is the previous code that it was running on, but I would like to make it a bit more flexible if the size of the range changes.
This would lookup '001' on data, and return the value from colB
Sub SaveAs()
For x = 1 To 5
Application.Worksheets("1034").Range("P2") = Format(x, "000")
Dim SaveName As String
SaveName = ActiveSheet.Range("P33").Text
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ActiveWorkbook.Path & "\1034\" & _
SaveName & ".pdf"
Next x
End Sub

Excel do not print if zero

my actual code is :
Option Explicit
Sub SaveMailActiveSheetAsPDFIn2016()
'Ron de Bruin : 1-May-2016
'Test macro to save/mail the Activesheet as pdf with ExportAsFixedFormat with Mail
Dim FileName As String
Dim FolderName As String
Dim Folderstring As String
Dim FilePathName As String
Dim strbody As String
'Check for AppleScriptTask script file that we must use to create the mail
If CheckAppleScriptTaskExcelScriptFile(ScriptFileName:="RDBMacMail.scpt") = False Then
MsgBox "Sorry the RDBMacMail.scpt is not in the correct location"
Exit Sub
End If
'My example sheet is landscape, I must attach this line
'for making the PDF also landscape, seems to default to
'xlPortait the first time you run the code
ActiveSheet.PageSetup.Orientation = xlLandscape
'Name of the folder in the Office folder
FolderName = "TempPDFFolder"
'Name of the pdf file
FileName = "Order " & [C1] & " " & Format(Date, "dd-mm-yyyy") & ".pdf"
Folderstring = CreateFolderinMacOffice2016(NameFolder:=FolderName)
FilePathName = Folderstring & Application.PathSeparator & FileName
'Create the body text in the strbody string
strbody = "Hi " & [C2] & "," & vbNewLine & vbNewLine & _
"Please find attached our new order" & vbNewLine & _
vbNewLine & _
"Thanks"
'expression A variable that represents a Workbook, Sheet, Chart, or Range object.
'Not working if you change activeworkbook, always save the activesheet
'Also the parameters are not working like in Windows
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
FilePathName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False
'Call the MacExcel2016WithMacMailPDF function to save the new pdf and create the mail
'When you use more mail addresses separate them with a ,
'Look in Mail>Preferences for the name of the mail account or signature
'Account name looks like this : "Your Name <your#mailaddress.com>"
MacExcel2016WithMacMailPDF subject:=[C6] & Format(Date, "dd/mm/yy"), _
mailbody:=strbody, _
toaddress:=[C3], _
ccaddress:=[C4], _
bccaddress:=[C5], _
attachment:=FilePathName, _
displaymail:=True, _
thesignature:="", _
thesender:=""
End Sub
I would like that all cells from E column in the print area =0 not to be displayed and that the sheet shrinks itself (like deleting the lines were =0), this before creating the .pdf document and opening mailbox.
I dunno if I'm clear enough sorry
Thank you for your help though
Assuming column E of Sheet1 is the one you want to hide if filled with zeros:
Sub hideZeroFilledColumn()
Dim rng As Range
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("E:E")
rng.EntireColumn.Hidden = (Excel.WorksheetFunction.Count(rng) = _
Excel.WorksheetFunction.CountIf(rng, "0"))
End Sub
Or, if you want to hide just the lines when cell value in column E:E is 0:
Sub hideLineWithZero()
Dim WS As Worksheet
Set WS = ThisWorkbook.Worksheets("Sheet1")
Dim strColumn As String
strColumn = "E" 'If the column you want to check is "E:E"
'Getting first row of printarea and setting "rngPrintStart" to that row in column strColumn
Dim rngPrintStart As Range
'The split is used to separate the start and end of the PrintArea address
'Here we take component "0" of the split, so the start part of the PrintArea
Set rngPrintStart = Range(Split(WS.PageSetup.PrintArea, ":")(0))
Set rngPrintStart = WS.Range(strColumn & rngPrintStart.Row)
'Getting last row of printarea and setting "rngPrintEnd" to that row in column strColumn
Dim rngPrintEnd As Range
'The split is used to seperate the start and end of the PrintArea address
'Here we take component "1" of the split, so the end part of the PrintArea
Set rngPrintEnd = Range(Split(WS.PageSetup.PrintArea, ":")(1))
Set rngPrintEnd = WS.Range(strColumn & rngPrintEnd.Row)
'Merging rngPrintStart and rngPrintEnd ranges from printarea in column strColumn
Dim rngPrintColumnE As Range
Set rngPrintColumnE = WS.Range(rngPrintStart, rngPrintEnd)
Dim rng As Range
Dim rngToHide As Range
'looking in all cells from rngPrintColumnE
For Each rng In rngPrintColumnE
'checking if cell value is equal to 0 and is not empty
If (rng.Value2 = 0) And (rng.Value2 <> "") Then
'Building the range to be hidden
If rngToHide Is Nothing Then 'For the first time when "rngToHide" is not yet set
Set rngToHide = rng
Else
Set rngToHide = Union(rngToHide, rng)
End If
End If
Next rng
'to hide the rows from the previously built range
rngToHide.Rows.EntireRow.Hidden = True
End Sub
I'm assuming you want to hide column E if all the values in it are zero?
Do a sum of the values into another cell (X99 in my example) then use the following code:
With ActiveSheet
If .Range("X99").Value = 0 Then
.Range("e:e").EntireColumn.Hidden = True
Else
.Range("e:e").EntireColumn.Hidden = False
End If
End With
Edit:
You can use Abs(Min(E:E))>0 instead of Sum if you have negative values
For some reason I can't add another answer so here goes with another edit.
To hide rows that have zero in the e column:
Dim i As Integer
Dim pa As Range
Dim ecolnumber As Integer
ecolnumber = 5
Set pa = Range(ActiveSheet.PageSetup.PrintArea)
For i = 0 To pa.Rows.Count
Dim ecell As Range
Set ecell = pa(i, ecolnumber)
ecell.EntireRow.Hidden = ecell.Value = 0
Next
Note the ecolnumber, you may have to change it to reference the correct column.
After you have done all your stuff you can unhide the rows with:
For i = 0 To pa.Rows.Count
Set ecell = pa(i, ecolnumber)
ecell.EntireRow.Hidden = False
Next

VBA Subscript out of range - error 9

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

Resources