VBa vlookup , replace range as variable - excel

OK I will reformulate the question.
I have a worksheet with a tab named"My INT".
This tab contains a data table and a button with an assigned macro called "importRMR". code below:
Sub importRMR()
Dim rng As Range
Set rng = ActiveSheet.Range("G3")
Sheets.Add(After:=ActiveSheet).Name = "RMR " & Format(Date, "DD-MM-YY")
ActiveSheet.Buttons.Add(966.75, 27.75, 153.75, 125.25).Select
Selection.OnAction = "Cimp"
Selection.Characters.Text = "Importuj"
With Selection.Characters(Start:=1, Length:=13).Font
.Name = "Tahoma"
.FontStyle = "Standaard"
.Size = 16
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
End With
End Sub
This creates a tab with a specific name :RMR " & Format(Date, "DD-MM-YY")
NOw I manually paste the table( always identical ) to the newly created tab "RMR 03/08/2018". the next step is to click the button in this tab ( Importuj) and the result I am aiming for is to :
1. Vlookup data in tab "my INT" where the range( lookup array) is tab "RMR" and then delete the rmr tab.
such procedures like triming the data pasting values and so on I am able to do, just the vlookup but is a problem.
my current code for "importuj " button is:
ub TEST()
Dim DOTR As String
Dim shT As String
Set shT = Sheets(DOTR).Range("E2:H584")
'shT = Sheets(DOTR).Range("c1:e2").Select
DOTR = "RMR " & Format(Date, "DD-MM-YY")
'Sheets(DOTR).Range ("E2:H584").selc
Worksheets("My INT").Range("N3").Formula = "=vlookup(c3,sht,3,0)"
End Sub
Unfortunately, I get an error - "Compile Error" - Object required.

The goal is to combine several different strings into a one cohesive string:
=VLOOKUP(C3,'ABCDEF 03-08-18'!$B$4:$D$10,3,0)
That will be placed inside a cell using:
Worksheet.Range.Formula
The worksheet name "ABCDEF" is arbitrary and we create the date on the fly. We use a named range in Excel "myNamedRange" and reference the address property to allow flexibility without editing code.
Dim strSheetName As String
Dim strNamedRange As String
Dim strDateSegment As String
Dim strPrefix As String
Dim shT As String
strSheetName = "My INT"
strNamedRange = "myNamedRange"
strDateSegment = Format(Day(Date), "00") & "-" & Format(Month(Date), "00") & "-" & Right(Year(Date), 2) & "'!"
strPrefix = "'" & "ABCDEF"
shT = "=VLOOKUP(C3," & strPrefix & strDateSegment & Worksheets(strSheetName).Range(strNamedRange).Address & ",3,0)"
Worksheets("My INT").Range("N3").Formula = shT

Related

EXCEL- Editing Excel's before copying to a new sheet with VBA

I have between 800 excels files that I need to transfer over to one sheet but before the transfer, I need to add a column ("A:A") and copy one cell value (before column added ("C1") after column ("D1")) and use column ("C:C") to get the range it would need to be pasted in column("A:A")
I have done the code already but struggling to add this on. If anyone can help that would be amazing.
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
Dim StartTime As Double
Dim MinutesElapsed As String
StartTime = Timer
On Error GoTo ErrorHandler
Set sh = ThisWorkbook.Worksheets("Sheet1")
' Change address to suite
MyDir = "C:\"
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
Dim x As Long
x = 0
' 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:DB" & TempSH.Range("A" & TempSH.Rows.Count).End(xlUp).Row)
TempRng.Range("A:A").Insert ' This is where I tried to add in the extra column
TempRng.Range("A1").Value = TempRng.Range("D1").Value ' Tried doing this as a test but still pasted as if no changes had been made????
'NewMasterLine is the last used row (+1) of the Master Workbook (It is basically where the new rows will 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 workbook
For Each TempRow In TempRng.Rows
If Left(TempRow.Cells(1, 2).Value, 5) = "SHIFT" Or TempRow.Row < 4 Then
'If TempRow.Cells(1, 2).Value = "SHIFT--1" Or TempRow.Row < 4 Then
Set MasterRange = sh.Range("A" & NewMasterLine & ":DA" & NewMasterLine)
MasterRange.Value = TempRow.Value
NewMasterLine = NewMasterLine + 1
End If
Next
TempWB.Close savechanges:=False
MyFile = Dir()
x = x + 1
ThisWorkbook.Worksheets("PWD").Range("H2") = x
Loop
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
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation
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 Center header/footer "Align Left"

Is there any way to align Center Header in Excel? I know there is no any built in solution but is there any VBA code that would work. I have been trying copying cells to header, setting center header with VBA but my Center Header is "Align Center" all the time.
I have even found very complex code to calculate length of sentences and add spaces to each row but it doesn't really work correctly.
I can also set rows to repeat on top and forget about header but what about footer then? How I can set Center Footer to align my two row text to align left?
I have tried:
With ActiveSheet.PageSetup
.LeftHeader = Range("a1").Value & " " & Range("b1").Value & " " & Range("a2").Value & " " & Range("b2").Value
End With
Also sending named range to header:
Option Explicit
Sub SetCenterHeader()
Dim txt As String
Dim myRow As Range
With Range("NorthHead") ' reference named range
For Each myRow In .Rows ' loop through referenced range rows
txt = txt & Join(Application.Transpose(Application.Transpose(myRow.Value)), " ") & vbLf ' update 'txt' with current row cells values joined and separated by a blank
Next
End With
ActiveSheet.PageSetup.CenterHeader = Left(txt, Len(txt) - 1) ' set CenterHeader with resulting 'txt' excluding last vblf character
ActiveWindow.SelectedSheets.PrintOut Copies:=1
End Sub
Result is always the same:
May try the following workaround and modify to your requirements
Sub test2()
Dim CenHd1 As String, CenHd2 As String, Fname As String
Dim Rng As Range
Dim Sht As Worksheet, MnSht As Worksheet
Dim Cht As ChartObject
Set Sht = ThisWorkbook.Worksheets(3)
Set MnSht = ThisWorkbook.Worksheets(1)
Set Rng = Sht.Range("F1:F2")
CenHd1 = "Excel"
CenHd2 = "I am already left Aligned"
Sht.Range("F1").Value = CenHd1
Sht.Range("F2").Value = CenHd2
Sht.Activate
ActiveWindow.DisplayGridlines = False
With Rng
.Columns.AutoFit 'added after taking trial snapshot to perfectly center and left align
.HorizontalAlignment = xlLeft
.Font.Name = "Bookman Old Style"
.Font.Size = 12
'May specify other visual effects
End With
Rng.CopyPicture xlScreen, xlPicture
Set Cht = Sht.ChartObjects.Add(0, 0, Rng.Width * 1.01, Rng.Height * 1.01)
Cht.Name = "TmpChart"
Sht.Shapes("TmpChart").Line.Visible = msoFalse
Cht.Chart.Paste
Fname = "C:\Users\user\Desktop\CentHead " & Format(Now, "dd-mm-yy hh-mm-ss") & ".jpg"
Cht.Chart.Export Filename:=Fname, Filtername:="JPG"
DoEvents
Cht.Delete
ActiveWindow.DisplayGridlines = True
MnSht.Activate
With MnSht.PageSetup.CenterHeaderPicture
.Filename = Fname
'.Height = 275.25
'.Width = 463.5
'.Brightness = 0.36
'.ColorType = msoPictureGrayscale
'.Contrast = 0.39
'.CropBottom = 0
'.CropLeft = 0
'.CropRight = 0
'.CropTop = 0
End With
'Enable the image to show up in the center header.
MnSht.PageSetup.CenterHeader = "&G"
'for Trial only
ActiveWindow.View = xlPageLayoutView
' Clear junk files
If Dir(Fname) <> "" Then Kill (Fname)
End Sub
Tried as follows
the code could also be modified as a function / procedure with parameters for repeated use with different Sheets, Workbooks etc. Hope it will help to serve the purpose.

VBA - Copy information to new workbook

I'm trying to do something that sounds incredibly simple but I can't figure out how to fit it into existing VBA code. The code below cycles through a pivot table 1 item at a time and copies that pivot table data out to a new workbook and emails to the staff member
All i need to add in is for it to copy (just values and formatting) a 13x2 table in the range E15:S16 on the same sheet as the pivot table, into the new workbook in the tab I've named "Monthly Forecast". with the loops etc i'm not sure how to get this into the code so it copies the pivot data and then the monthly forecast into the separate tab
Hope that makes sense, any help would be wonderful :)
Option Explicit
Sub PivotSurvItems()
Dim i As Integer
Dim sItem As String
Dim sName As String
Dim sEmail As String
Dim OutApp As Object
Dim OutMail As Object
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
With ActiveSheet.PivotTables("PivotTable1")
.PivotCache.MissingItemsLimit = xlMissingItemsNone
With .PivotFields("Staff")
'---hide all items except item 1
.PivotItems(1).Visible = True
For i = 2 To .PivotItems.Count
.PivotItems(i).Visible = False
Next
For i = 1 To .PivotItems.Count
.PivotItems(i).Visible = True
If i <> 1 Then .PivotItems(i - 1).Visible = False
sItem = .PivotItems(i)
ActiveSheet.PivotTables("PivotTable1").PivotSelect "", xlDataAndLabel, True
Selection.Copy
Workbooks.Add
With ActiveWorkbook
.Sheets(1).Cells(1).PasteSpecial _
Paste:=xlPasteValuesAndNumberFormats
Worksheets("Sheet1").Columns("A:R").AutoFit
ActiveSheet.Range("A2").AutoFilter
sName = Range("C" & 2)
sEmail = Range("N" & 2)
Columns(1).EntireColumn.Delete
Columns(2).EntireColumn.Delete
Columns(2).EntireColumn.Delete
Columns(2).EntireColumn.Delete
Columns(10).EntireColumn.Delete
ActiveSheet.Name = "FCW"
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Monthly Forecast"
Worksheets("FCW").Activate
'create folder
On Error Resume Next
MkDir "C:\Temp\FCW" & "\" & sName
On Error GoTo 0
.SaveAs "C:\Temp\FCW" & "\" & sName & "\" & sItem & " " & Format(Now(), "DD-MM-YYYY") & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = sEmail
.CC = ""
.BCC = ""
.Subject = "Planning Spreadsheet"
.Attachments.Add ActiveWorkbook.FullName
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
.Close
End With
Next i
End With
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub
Instead of changing visibility and cycling through all the items in the pivot table, assign the values to a 'table' (a range) and pass it to where you want it to go (it's much faster than using Excel's .copy and .PasteSpecial in VBA.
Also, I suggest that you copy all the data to an 'outputs' worksheet in the same workbook. When all the data has been copied, export that specific outputs worksheet into a new workbook. This way you avoid copying and pasting data between two different workbooks which can be prone to errors.
In your code, I would remove everything from the item cycling down until the Temp folder creation and replace it with something like the following:
'Copy values
Set rStartCell = ActiveSheet.Range("A1") 'Specify the top-left corner cell of the data you wish to copy
Set rTable_1 = ActiveSheet.Range(rStartCell, ActiveSheet.Range("Z" & rStartCell.End(xlDown).Row)) 'Change the Z column to the last column of the data you wish to copy. You can automate this by using something like Range(A1).end(xltoright).columns.count formula to grab the number of columns.
Debug.Print "rTable_1: " & rTable_1.Address & " -> " & rTable_1.Rows.Count & " x " & rTable_1.Columns.Count 'good to test exactly what you're copying
'Paste Values
Set rStartCell = Outputs.Range("A1") 'Change A1 to the cell of where you want to paste on the Outputs worksheet in your original workbook.
Set rTable_2 = Outputs.Range(rStartCell, rStartCell.Offset(rTable_1.Rows.Count - 1, rTable_1.Columns.Count - 1))
Debug.Print "rTable_2: " & rTable_2.Address & " -> " & rTable_2.Rows.Count & " x " & rTable_2.Columns.Count
rTable_2.Value = rTable_1.Value
rTable_1.Copy
rTable_2.PasteSpecial Paste:=xlPasteFormats 'to copy/paste those formats you need
'Copy Worksheet and open it in a new workbook
ThisWorkbook.Sheets("NAME OF OUTPUTS SHEET").Copy 'Using ThisWorkbook to point to the workbook holding this code.
ActiveSheet.Name = "FCW"
You can use this method to copy/paste that other table mentioned as well.

Best methods to reference a user function in a macro

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

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