Macro calling a function without being required (VBA) - excel

I made this sub in VBA which copies the contents of a sheet to a new sheet, then format and save this as a .csv. But when I'm debugging this, the sub jumps alone to a function in another module and starts an infinite loop.
Depending on the organization of the commands, it jumps before or after for this function, but always skips.
in the current sub is jumping in the ".move" command.
I have not found the solution because the polls always return something like: "How to do a sub automatically call a function?" But that is precisely what is happening to me without my will.
That is my Sub
Sub TCzor()
'
Dim MData, MStr
Dim ultimalinha As Integer
Dim valorA As String
Dim valorB As String
Dim valorC As String
Dim valorD As String
Dim sUserName As String
MData = Date
MStr = Format(MData, "ddmm")
sUserName = Environ$("username")
'
Windows("MultiTrat.xlsm").Activate
Sheets("MultiTrat").Select
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "TCzor"
Sheets("MultiTrat").Select
Range("AX3:BF111").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("TCzor").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Application.CutCopyMode = False
Selection.AutoFilter
ActiveSheet.Range("$A$1:$I$109").AutoFilter Field:=1, Criteria1:="="
Rows("2:2").Select
Range(Selection, Rows("1000:1000")).Select
Selection.Delete Shift:=xlUp
Selection.AutoFilter
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Columns("B:B").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("G:G").Select
Selection.Cut
Columns("B:B").Select
ActiveSheet.Paste
Columns("D:D").Select
Selection.Delete Shift:=xlToLeft
Columns("E:E").Select
Range(Selection, Columns("XFD:XFD")).Select
Selection.Delete Shift:=xlToLeft
Range("D1").Value = "Valor"
Columns("D:D").Select
Selection.NumberFormat = "0.00"
ultimalinha = Range("A1").End(xlDown).Row
For linha = 2 To ultimalinha
If Cells(linha, 3).Value = "C" Then
Cells(linha, 3).Value = "Créd"
Else
Cells(linha, 3).Value = "Déb"
End If
Next linha
For linha = 1 To ultimalinha
valorA = Cells(linha, 1)
valorB = Cells(linha, 2)
valorC = Cells(linha, 3)
valorD = Cells(linha, 4)
Cells(linha, 1) = valorA & ";" & valorB & ";" & valorC & ";" & valorD
Next linha
Range("B:D").Delete
Sheets("TCzor").Select
Sheets("TCzor").Move
ChDir "C:\Users\" & sUserName & "\Desktop"
ActiveWorkbook.SaveAs Filename:= _
"C:\Users\" & sUserName & "\Desktop\TC" & MStr & ".csv", FileFormat:=xlCSV, _
CreateBackup:=False
ActiveWindow.Close
Windows("tczor_jv.xlsm").Activate
End Sub
And this is the Function that it is calling by itself
Function GetARN(Myrange As Range) As String
Dim regex As New RegExp
Dim strPattern As String
Dim strInput As String
Dim strReplace As String
Dim strOutput As String
strPattern = "[0-9]{23}"
strInput = Myrange.Value
With regex
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = strPattern
End With
Set matches = regex.Execute(strInput)
For Each Match In matches
GetARN = Match.Value
Next Match

Related

Activesheet shifting away from original sheet on second iteration of the substatement

I can run this program one iteration at a time, but when I let it run on the next i, the VarCellValues come back as values from a different sheet. What would be causing the active sheet to change away from the workbook and first sheet the macro is opened from?
Sub copy_financials_2022()
'
' copy_financials_2022 Macro
'
Dim i As Integer
Dim VarCellValue As String
Dim VarCellValue2 As String
Dim VarCellValue3 As String
Dim VarCellValue4 As String
Dim VarCellValue5 As String
Dim currwbk As Workbook
Set currwbk = ThisWorkbook
For i = Range("A2").Value To Range("C2").Value
Set currwbk = ThisWorkbook
VarCellValue = Range("B" & i).Value
VarCellValue2 = Range("C" & i).Value
VarCellValue3 = Range("A" & i).Value
VarCellValue4 = Range("D" & i).Value
VarCellValue5 = Range("E" & i).Value
Application.DisplayAlerts = False
Workbooks.Open (Range("A3").Value & VarCellValue4 & ".xlsx")
'Workbooks.Open ("S:\Finance\_2022 FINANCIAL REPORTS\National Financials\09-30\CONSOLIDATED MONTHLY FINANCIAL STATEMENT" & ".xlsm")
'Workbooks.Open (Range("B3").Value & VarCellValue4)
Workbooks(VarCellValue4).Activate
'inserted "Sheets(VarCellValue5).Activate" below after the third tab was active on Los Angeles Sheet (should have been the first tab)
Sheets(VarCellValue5).Activate
Sheets(VarCellValue5).Unprotect Password:="forecast22"
Columns("A:S").Select
Selection.EntireColumn.Hidden = False
Workbooks.Open ("S:\Finance\_2022 FINANCIAL REPORTS\National Financials\09-30\CONSOLIDATED MONTHLY FINANCIAL STATEMENT" & ".xlsm")
Sheets(VarCellValue2).Activate
Range("A6:Q6").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Range("A6:Q88").Select
Selection.Copy
Workbooks(VarCellValue4).Activate
Range("A6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B:B,D:E,G:G,I:J,L:N,K:K").Select
Range("K1").Activate
Selection.EntireColumn.Hidden = True
Range("C7").Select
'Range("A6").Select
Application.CutCopyMode = False
ActiveWorkbook.Save
Range("C7").Select
ActiveCell.FormulaR1C1 = "Sept MTD"
Range("H7").Select
ActiveCell.FormulaR1C1 = "Sept YTD"
Range("S8").Select
ActiveCell.FormulaR1C1 = "Aug - Dec 2021"
Range("A6").Select
ActiveSheet.Protect Password:="forecast22"
ActiveWorkbook.Save
ActiveWindow.Close
'Workbooks.Close ("S:\Finance\_2022 FINANCIAL REPORTS\National Financials\05-31\CONSOLIDATED MONTHLY FINANCIAL STATEMENT" & ".xlsm")
Next i
End Sub
Instead of relying on a sheet being active, fully qualify each Range call with the appropriate workbook/worksheet.
Dim currwbk As Workbook
Set currwbk = ThisWorkbook
Dim currWs As Worksheet
Set currWs = currwbk.ActiveSheet
For i = currWs.Range("A2").Value To currWs.Range("C2").Value
VarCellValue = currWs.Range("B" & i).Value
VarCellValue2 = currWs.Range("C" & i).Value
VarCellValue3 = currWs.Range("A" & i).Value
VarCellValue4 = currWs.Range("D" & i).Value
VarCellValue5 = currWs.Range("E" & i).Value
Dim wb As Workbook
Set wb = Workbooks.Open(currWs.Range("A3").Value & VarCellValue4 & ".xlsx")
With wb.Worksheets(VarCellValue5)
.Unprotect Password:="forecast22"
.Columns("A:S").Hidden = False
' and so on
End With
Next

I am not able to filter by Current date in excel column (AA)

I am not able to filter column (AA) Based on current date,column AA contains dates and its data type also date
please help me
[I am attching screenshot of column AA][1]
Sub Macro3()
'
' Macro3 Macro
'
'
Dim count As Integer
count = 0
Dim dDate As Date
dDate = Format(Date, "dd/mm/yyyy")
MsgBox (dDate)
Dim j As Integer
Dim MyArr(16) As String
For j = 2 To 16
MyArr(j) = Cells(j, 29).Value
Next
Dim nFirst As Long, nLast As Long, i As Long
Dim item As String
Dim arrTemp() As String
Dim Coll As New Collection
'Get First and Last Array Positions
nFirst = LBound(MyArr)
nLast = UBound(MyArr)
ReDim arrTemp(nFirst To nLast)
'Convert Array to String
For i = nFirst To nLast
arrTemp(i) = CStr(MyArr(i))
Next i
'Populate Temporary Collection
On Error Resume Next
For i = nFirst To nLast
Coll.Add arrTemp(i), arrTemp(i)
Next i
Err.Clear
On Error GoTo 0
'Resize Array
nLast = Coll.count + nFirst - 1
ReDim arrTemp(nFirst To nLast)
'Populate Array
For i = nFirst To nLast
arrTemp(i) = Coll(i - nFirst + 1)
Next i
For i = 1 To nLast
MsgBox (arrTemp(i))
Selection.AutoFilter
MsgBox (Cells(2, 27).Value)
ActiveSheet.Range("$A$1:$AN$16").AutoFilter Field:=27, Operator:= _
xlFilterValues, Criteria2:=Array(1, dDate)
ActiveSheet.Range("$A$1:$AN$16").AutoFilter Field:=29, Criteria1:= _
arrTemp(i)
Selection.Copy
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets.Add After:=ActiveSheet
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("B:N").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Columns("C:N").Select
Selection.Delete Shift:=xlToLeft
Columns("C:E").Select
Range("E1").Activate
Selection.Delete Shift:=xlToLeft
Columns("E:P").Select
Selection.Delete Shift:=xlToLeft
Range("A1:C1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
count = count + 1
Next
End Sub
[1]: https://i.stack.imgur.com/wX8zt.png

How to optimize multiple loops in VBA code within Excel

I am not a very efficient vba coder, but I can brute force my way through something. I am trying to optimize this code to have it run more quickly. I would imagine it should be possible to combine the loops somehow, but I am not exactly sure where to start since the Sheets are within the formulas. Any assistance would be greatly appreciated.
Sub Import()
Application.EnableEvents = False 'This stops the background codes on the sheets from activating (smoothens out the process).
Application.ScreenUpdating = False 'Stops the screen from switching back and forth between the Input and the Master
Application.DisplayAlerts = False
If InStr(1, Worksheets("Lookup").Range("B44").Value, "STATE1", vbTextCompare) <> 0 Then
Sheets("SHEET2").Activate
Range("A4").Select
ElseIf InStr(1, Worksheets("Lookup").Range("B44").Value, "STATE2", vbTextCompare) <> 0 Then
Sheets("SHEET2").Activate
Range("A4").Select
ElseIf InStr(1, Worksheets("Lookup").Range("B44").Value, "STATE3", vbTextCompare) <> 0 Then
Sheets("SHEET2").Activate
Range("A4").Select
ElseIf InStr(1, Worksheets("Lookup").Range("B44").Value, "All", vbTextCompare) <> 0 Then
Sheets("SHEET2").Activate
Range("A4").Select
Else:
Sheets("SHEET1").Columns("KA:KC").Hidden = True
Sheets("SHEET2").Columns("KA:KC").Hidden = True
Sheets("SHEET3").Columns("KA:KC").Hidden = True
Sheets("SHEET4").Columns("KA:KC").Hidden = True
MsgBox "Doesn't exist for these locations"
Exit Sub
End If
Sheets("SHEET1").Columns("KA:KC").Hidden = False
Sheets("SHEET2").Columns("KA:KC").Hidden = False
Sheets("SHEET3").Columns("KA:KC").Hidden = False
Sheets("SHEET4").Columns("KA:KC").Hidden = False
`'This removes the old DATASHEET tab from the model before starting (if it exists)
Dim SummaryWB As Workbook
Dim vrtSelectedItem As Variant
For Each Sheet In ActiveWorkbook.Worksheets
If Sheet.Name = "DATASHEET" Then
Sheet.Delete
End If
Next Sheet
''' The below opens the RRS file from the file path defined
Workbooks.Open Filename:="\\Template_Current.xlsx"
'' This just pauses the operating for 1 second to allow the file to be opened seamlessly, can probably be removed.
Application.Wait Now + #12:00:01 AM#
'' This copies the Data from the RRS file and moves it into the CPM model in a new tab, and renames it.
'' It then closes the Source file.
Sheets("Data").Select
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Windows("Report.xlsm").Activate
Sheets("YAdd").Select
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
ActiveSheet.Select
ActiveSheet.Name = "DATASHEET"
Windows("Template_Current.xlsx").Activate
Sheets("List View").Select
Range("D3").Select
Selection.Copy
Windows("Report.xlsm").Activate
Sheets("DATASHEET").Select
Range("W1").Select
ActiveSheet.Paste
Windows("Template_Current.xlsx").Activate
ActiveWorkbook.Close True
Windows("Report.xlsm").Activate
'' and performs a lookup against the DATASHEET tab, matching the Account Number. It currently only
'' shows values if they are found/non-zero. It also clears old data from the columns
'' This also copies the outputed data and pastes only the values.
'' By doing so, we are saving future memory space, so that it doesn't need to recalc everytime you open
'' the file, only when you run this macro.
Sheets("SHEET1").Select
Range("KA25:KC5000").Select
Selection.Delete
Dim LastRow As Long, i As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 25 To LastRow
Range("KA1").Offset(i - 1, 0).Select
ActiveCell.FormulaR1C1 = _
"=IF(SUMIF(DATASHEET!R2C1:R712C1,SHEET1!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275])>0,SUMIF(DATASHEET!R2C1:R712C1,SHEET1!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]),"""")"
Range("KB1").Offset(i - 1, 0).Select
ActiveCell.FormulaR1C1 = _
"=IF(SHEET1!RC[-1]="""","""",If(SHEET1!RC[-1]>1.1,""RED"",If(SHEET1!RC[-1]<0.8,""GREEN"",""YELLOW"")))"
Range("KC1").Offset(i - 1, 0).Select
ActiveCell.FormulaR1C1 = _
"=IF(SHEET1!RC[-1]="""","""",SUMIF(DATASHEET!R2C1:R712C1,SHEET1!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]))"
Next i
Sheets("SHEET1").Select
Range("KA25").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Selection.PasteSpecial xlPasteValues
Range("KA25").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00"
Range("KC25").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00%"
Range("KA25").Select
Sheets("SHEET2").Select
Range("KA25:KC5000").Select
Selection.Delete
Dim LastRow1 As Long, i1 As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i1 = 25 To LastRow
Range("KA1").Offset(i1 - 1, 0).Select
ActiveCell.FormulaR1C1 = _
"=IF(SUMIF(DATASHEET!R2C1:R712C1,SHEET2!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275])>0,SUMIF(DATASHEET!R2C1:R712C1,SHEET2!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]),"""")"
Range("KB1").Offset(i1 - 1, 0).Select
ActiveCell.FormulaR1C1 = _
"=IF(SHEET2!RC[-1]="""","""",If(SHEET2!RC[-1]>1.1,""RED"",If(SHEET2!RC[-1]<0.8,""GREEN"",""YELLOW"")))"
Range("KC1").Offset(i1 - 1, 0).Select
ActiveCell.FormulaR1C1 = _
"=IF(SHEET2!RC[-1]="""","""",SUMIF(DATASHEET!R2C1:R712C1,SHEET2!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]))"
Next i1
Sheets("SHEET2").Select
Range("KA25").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Selection.PasteSpecial xlPasteValues
Range("KA25").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00"
Range("KC25").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00%"
Range("KA25").Select
Sheets("SHEET3").Select
Range("KA25:KC5000").Select
Selection.Delete
Dim LastRow2 As Long, i2 As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i2 = 25 To LastRow
Range("KA1").Offset(i2 - 1, 0).Select
ActiveCell.FormulaR1C1 = _
"=IF(SUMIF(DATASHEET!R2C1:R712C1,SHEET3!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275])>0,SUMIF(DATASHEET!R2C1:R712C1,SHEET3!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]),"""")"
Range("KB1").Offset(i2 - 1, 0).Select
ActiveCell.FormulaR1C1 = _
"=IF(SHEET3!RC[-1]="""","""",If(SHEET3!RC[-1]>1.1,""RED"",If(SHEET3!RC[-1]<0.8,""GREEN"",""YELLOW"")))"
Range("KC1").Offset(i2 - 1, 0).Select
ActiveCell.FormulaR1C1 = _
"=IF(SHEET3!RC[-1]="""","""",SUMIF(DATASHEET!R2C1:R712C1,SHEET3!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]))"
Next i2
Sheets("SHEET3").Select
Range("KA25").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Selection.PasteSpecial xlPasteValues
Range("KA25").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00"
Range("KC25").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00%"
Range("KA25").Select
Sheets("SHEET4").Select
Range("KA25:KC5000").Select
Selection.Delete
Dim LastRow3 As Long, i3 As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i3 = 25 To LastRow
Range("KA1").Offset(i3 - 1, 0).Select
ActiveCell.FormulaR1C1 = _
"=IF(SUMIF(DATASHEET!R2C1:R712C1,SHEET4!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275])>0,SUMIF(DATASHEET!R2C1:R712C1,SHEET4!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]),"""")"
Range("KB1").Offset(i3 - 1, 0).Select
ActiveCell.FormulaR1C1 = _
"=IF(SHEET4!RC[-1]="""","""",If(SHEET4!RC[-1]>1.1,""RED"",If(SHEET4!RC[-1]<0.8,""GREEN"",""YELLOW"")))"
Range("KC1").Offset(i3 - 1, 0).Select
ActiveCell.FormulaR1C1 = _
"=IF(SHEET4!RC[-1]="""","""",SUMIF(DATASHEET!R2C1:R712C1,SHEET4!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]))"
Next i3
Sheets("SHEET4").Select
Range("KA25").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Selection.PasteSpecial xlPasteValues
Range("KA25").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00"
Range("KC25").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.NumberFormat = "0.00%"
Range("KA25").Select
Sheets("DATASHEET").Visible = xlSheetHidden
Application.EnableEvents = True 'Turns background code back on.
Application.ScreenUpdating = True 'Turns ScreenUpdating back on.
Application.DisplayAlerts = True 'Turns Alerts back on.
MsgBox "Import Complete"
End Sub
You want to avoid repeating yourself. Whenever you have duplicate code you need to break it out in to it's own procedure and then call it using the variable that makes it unique. In your case the only unique part is the sheet you are operating on. So I made this example procedure that you can pass sheet objects to:
Private Sub ProcessSheet(thisSheet As Worksheet)
thisSheet.Range("KA25:KC5000").Delete
Dim LastRow As Long, i As Long
LastRow = thisSheet.Cells(thisSheet.Rows.Count, "A").End(xlUp).Row
For i = 25 To LastRow
thisSheet.Range("KA1").Offset(i - 1, 0).FormulaR1C1 = _
"=IF(SUMIF(DATASHEET!R2C1:R712C1," & thisSheet.Name & "!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275])>0,SUMIF(DATASHEET!R2C1:R712C1," & thisSheet.Name & "!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]),"""")"
thisSheet.Range("KB1").Offset(i - 1, 0).FormulaR1C1 = _
"=IF(" & thisSheet.Name & "!RC[-1]="""","""",If(" & thisSheet.Name & "!RC[-1]>1.1,""RED"",If(" & thisSheet.Name & "!RC[-1]<0.8,""GREEN"",""YELLOW"")))"
thisSheet.Range("KC1").Offset(i - 1, 0).FormulaR1C1 = _
"=IF(" & thisSheet.Name & "!RC[-1]="""","""",SUMIF(DATASHEET!R2C1:R712C1," & thisSheet.Name & "!R25C2:R59C2,DATASHEET!R2C[-275]:R712C[-275]))"
Next i
With thisSheet
.Range("KA25").UsedRange = Sheets("SHEET1").Range("KA25").UsedRange
.Range("KA25", Selection.End(xlDown)).NumberFormat = "0.00"
.Range("KC25", Selection.End(xlDown)).NumberFormat = "0.00%"
End With
End Sub
Then you can call it from your main import procedure like this:
Sub Import()
With Application
.EnableEvents = False 'This stops the background codes on the sheets from activating (smoothens out the process).
.ScreenUpdating = False 'Stops the screen from switching back and forth between the Input and the Master
.DisplayAlerts = False
End With
If InStr(1, Worksheets("Lookup").Range("B44").Value, "STATE1", vbTextCompare) <> 0 Then
Sheets("SHEET2").Activate
Range("A4").Select
ElseIf InStr(1, Worksheets("Lookup").Range("B44").Value, "STATE2", vbTextCompare) <> 0 Then
Sheets("SHEET2").Activate
Range("A4").Select
ElseIf InStr(1, Worksheets("Lookup").Range("B44").Value, "STATE3", vbTextCompare) <> 0 Then
Sheets("SHEET2").Activate
Range("A4").Select
ElseIf InStr(1, Worksheets("Lookup").Range("B44").Value, "All", vbTextCompare) <> 0 Then
Sheets("SHEET2").Activate
Range("A4").Select
Else
Sheets("SHEET1").Columns("KA:KC").Hidden = True
Sheets("SHEET2").Columns("KA:KC").Hidden = True
Sheets("SHEET3").Columns("KA:KC").Hidden = True
Sheets("SHEET4").Columns("KA:KC").Hidden = True
MsgBox "Doesn't exist for these locations"
Exit Sub
End If
Sheets("SHEET1").Columns("KA:KC").Hidden = False
Sheets("SHEET2").Columns("KA:KC").Hidden = False
Sheets("SHEET3").Columns("KA:KC").Hidden = False
Sheets("SHEET4").Columns("KA:KC").Hidden = False
'This removes the old DATASHEET tab from the model before starting (if it exists)
Dim SummaryWB As Workbook
Dim vrtSelectedItem As Variant
For Each Sheet In ActiveWorkbook.Worksheets
If Sheet.Name = "DATASHEET" Then
Sheet.Delete
End If
Next Sheet
''' The below opens the RRS file from the file path defined
Dim RRSFile As Workbook
Set RRSFile = Workbooks.Open(Filename:="\\Template_Current.xlsx")
'' This will allow the workbook to open before continuing
DoEvents
'' This copies the Data from the RRS file and moves it into the CPM model in a new tab, and renames it.
'' It then closes the Source file.
Dim dataRange As Range
dataRange = RRSFile.Sheets("Data").Range("A1").UsedRange
Dim dataSheet As Worksheet
Windows("Report.xlsm").Activate
Set dataSheet = Sheets.Add(After:=Sheets("YAdd"))
dataSheet.Range("A1") = dataRange
dataSheet.Name = "DATASHEET"
RRSFile.Sheets("List View").Range ("D3")
dataSheet.Range("W1") = RRSFile.Sheets("List View").Range("D3")
RSSFile.Close True
Windows("Report.xlsm").Activate
'' and performs a lookup against the DATASHEET tab, matching the Account Number. It currently only
'' shows values if they are found/non-zero. It also clears old data from the columns
'' This also copies the outputed data and pastes only the values.
'' By doing so, we are saving future memory space, so that it doesn't need to recalc everytime you open
'' the file, only when you run this macro.
ProcessSheet Sheets("SHEET1")
ProcessSheet Sheets("SHEET2")
ProcessSheet Sheets("SHEET3")
ProcessSheet Sheets("SHEET4")
Sheets("DATASHEET").Visible = xlSheetHidden
With Application
.EnableEvents = True 'Turns background code back on.
.ScreenUpdating = True 'Turns ScreenUpdating back on.
.DisplayAlerts = True 'Turns Alerts back on.
End With
MsgBox "Import Complete"
End Sub
The big benefit you get here is that you can change that code in one place and it affects all 4 of your loops. Instead of trying to maintain 4 identical copies of the same code.

Making a new copy with only values - Excel VBA

I have to write a code that will make copy of two sheets into new workbook. However, I receve error message and the values do not show..
Public Sub CopySheetAndRename()
Dim newName As String
On Error Resume Next
newName = InputBox("Enter the name for the copied worksheet")
If newName <> "" Then
ActiveSheet.Copy After:=Worksheets(Sheets.Count)
On Error Resume Next
ActiveSheet.Name = newName
End If
End Sub
Sub SaveSheets()
Application.DisplayAlerts = False
Dim myFile
Dim myCount
Dim actSheet
Dim i
Dim WsTabelle As Worksheet
'mypath = InputBox("Enter the path", "Save to...", "C:\temp")
mypath = "C:\temp"
ChDrive mypath
ChDir mypath
Sheets("Fertigstellungsgrad aktuell").Select
Sheets("Fertigstellungsgrad aktuell").Copy Before:=Sheets("Fertigstellungsgrad aktuell")
Sheets("Fertigstellungsgrad aktuell").Select
Sheets("Fertigstellungsgrad aktuell (2)").Name = "Fertigstellungsgrad xx.xx.xx"
ActiveWorkbook.SaveAs Filename:= _
"C:\temp\Bearbeitungsstatus.xlsm" _
, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
' Löschen überflüssiger Sheets
For Each WsTabelle In Sheets
With WsTabelle
' Dein Makro, Cells und Range mit Punkt
actSheet = .Name
If .Name = "Fertigstellungsgrad xx.xx.xx" Then
' mache nichts
actSheet = .Name
ElseIf .Name = "Übersicht AP-Verbrauch" Then
' mache nichts
actSheet = .Name
Else
WsTabelle.Delete
End If
End With
Next WsTabelle
ActiveWorkbook.SaveAs Filename:= _
" C:\temp \Bearbeitungsstatus.xlsm" _
, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End Sub
Public Sub SubstitudeFieldValues()
Sheets("Fertigstellungsgrad xx.xx.xx").Select
' Find the last row of data
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
FinalCol = Cells(1, Columns.Count).End(xlToLeft).Column
' Loop through each row
For Col = 1 To FinalCol
colTitle = Cells(1, Col).Value
If colTitle = "K1" Or _
colTitle = "K2" Or _
colTitle = "K3" Or _
colTitle = "S1" Or _
colTitle = "S2" Or _
colTitle = "S3" Or _
colTitle = "P1" Or _
colTitle = "P2" Or _
colTitle = "P3" Or _
colTitle = "T1" Or _
colTitle = "T2" Or _
colTitle = "T3" Or _
colTitle = "A1" Or _
colTitle = "A2" Or _
colTitle = "D1" Or _
colTitle = "D2" Then
For x = 2 To FinalRow
wert = Cells(x, Col)
If wert <> Leer Then
'Range(Cells(x, Col), Cells(x, Col)).Select
Cells(x, Col).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Next x
End If
Next Col
End Sub
The original task is to make copy of two sheets in the new workbook.
Making a copy of "Fertigstellungsgrad" with ability of rename (It should be called "Fertigstellungsgrad xx.xx.xx" - Date.Month.Year) and the copy should contain only values. "Übersicht AP-Verbrauch"(this one should stay the same, without any changes)
https://i.stack.imgur.com/Soxq7.png
Kind regards, Mario
There are spaces in the filenames in Sub SaveSheets()
I changed:
ActiveWorkbook.SaveAs Filename:= _
" C:\temp \Bearbeitungsstatus.xlsm" _
, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
to
ActiveWorkbook.SaveAs Filename:= _
"C:\temp\Bearbeitungsstatus.xlsm" _
, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
and I could save the file.
I modified the code below from an IF / FOR to a CASE SELECT and modified the range for FinalRow variable to be the current column used range. It looks like your For / Next statement in the sub is pseudo code so I haven't made any changes to it.
Public Sub SubstitudeFieldValues()
Sheets("Fertigstellungsgrad xx.xx.xx").Select
' Find the last row of data
'FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
FinalCol = Cells(1, Columns.Count).End(xlToLeft).Column
' Loop through each row
For Col = 1 To FinalCol
colTitle = Cells(1, Col).Value
Select Case colTitle
Case "K1", "K2", "K3", "S1", "S2", "S3", "P1", "P2", "P3", "T1", "T2", "T3", "A1", "A2", "D1", "D2"
FinalRow = Range(colTitle).End(xlDown).Row
Case else
goto NotFound
End Select
For x = 2 To FinalRow
wert = Cells(x, Col)
If wert <> Leer Then
'Range(Cells(x, Col), Cells(x, Col)).Select
Cells(x, Col).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
Next x
NotFound:
Next Col
End Sub
To set the name of the new sheet to include the date, you can change your code in SaveSheets() from:
Sheets("Fertigstellungsgrad aktuell (2)").Name = "Fertigstellungsgrad xx.xx.xx"
to
Sheets("Fertigstellungsgrad aktuell (2)").Name = "Fertigstellungsgrad " & Format(Now(), "dd.mm.yy")
Your subsequent Select statement in Sub SubstitudeFieldValues() would become:
Public Sub SubstitudeFieldValues()
Sheets("Fertigstellungsgrad " & Format(Now(), "dd.mm.yy").Select

Setting excel VBA Range from multiple variables

I'm having trouble with the Range function. (Nearly) completed code below. I'm fairly new to VBA, so please explain the basics if you have the time. This is the line that is giving me a debug error:
Set CombinedPropRange = ThisWorkbook.Worksheets("PropFiltered").Range("A" & _
PropACount & ":J" & SplitTabName(2))
Full Code Below:
Sub FillTabsTest()
' FillTabsTest Macro
HowManyTabsDoYouNeed = 4 'If you want to add or remove Tabs, you must change this number AND add/subtract from the "TabName(1)" section below.
ReDim TabName(1 To HowManyTabsDoYouNeed) As String
'Grabs Data from Original Workbook and creates a new Workbook.
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range("A1:P1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Call WrapText
TabName(1) = "April H.,0,1000"
TabName(2) = "Christopher H.,0,1000"
TabName(3) = "Christie E.,500,500"
TabName(4) = "Cori M.,500,500"
'Places Filtered Auto Events on its own tab
Sheets("Sheet1").Select
Cells.Select
Selection.AutoFilter
ActiveSheet.Range("$A:$S").AutoFilter Field:=8, Criteria1:="=COMAUTO", _
Operator:=xlOr, Criteria2:="=PERSAUTO"
ActiveSheet.Range("$A:$S").AutoFilter Field:=5, Criteria1:="=3*", Operator _
:=xlAnd
ActiveSheet.Range("$A:$S").AutoFilter Field:=9, Criteria1:=Array( _
"AUTO BODILY INJURY", "AUTO MED PAY", "AUTO PROPERTY DAMAGE", "AUTO-ENDORSEMENT", _
"AUTO-OTHER", "BODILY INJURY", "COLLISION", "COMPREHENSIVE", "LIABILITY", "OTHER", _
"RENTAL REIMBURSEMENT", "UM/UIM"), Operator:=xlFilterValues
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "AutoFiltered"
ActiveSheet.Paste
'Places Filtered Property Events on its own tab
Sheets("Sheet1").Select
Cells.Select
Application.CutCopyMode = False
ActiveSheet.ShowAllData
Cells.Select
ActiveSheet.Range("$A:$S").AutoFilter Field:=8, Criteria1:="=COMPROP", _
Operator:=xlOr, Criteria2:="=PLPROP"
ActiveSheet.Range("$A:$S").AutoFilter Field:=5, Criteria1:="=3*", Operator _
:=xlAnd
ActiveSheet.Range("$A:$S").AutoFilter Field:=12, Criteria1:="<>*FIRE*", _
Operator:=xlOr, Criteria2:="<>*SMOKE*"
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "PropFiltered"
ActiveSheet.Paste
'Begin adding the above named tabs to the workbook
For i = 1 To HowManyTabsDoYouNeed
Sheets.Add After:=Sheets(Sheets.Count)
SplitTabName = Split(TabName(i), ",")
ActiveSheet.Name = SplitTabName(0)
Next i
'Begin populating employee's sheets.
Dim AutoACount As Integer
Dim PropACount As Integer
' Dim AutoAPasteCount As Integer
Dim PropAPasteCount As Integer
Dim AutoJCount As Integer
Dim PropJCount As Integer
'Dim AutoRangeA As Range
'Dim AutoRangeJ As Range
'Dim PropRangeA As Range
'Dim PropRangeJ As Range
Dim PropAPasteCountRange As String
Dim CombinedPropRange As Range
Dim CombinedAutoRange As Range
AutoACount = 2
PropACount = 2
AutoJCount = 2
PropJCount = 2
PropAPasteCount = 2
For i = 1 To HowManyTabsDoYouNeed
SplitTabName = Split(TabName(i), ",")
If SplitTabName(1) <> "0" Then
' Set AutoRangeA = Range("A" & AutoACount)
' Set AutoRangeJ = Range("J" & SplitTabName(1))
Sheets("AutoFiltered").Select
Set CombinedAutoRange = ThisWorkbook.Worksheets("AutoFiltered").Range("A" & AutoACount & ":J" & SplitTabName(1))
CombinedAutoRange.Copy
Sheets("SplitTabName(0)").Select
ActiveSheet.Paste
AutoACount = AutoACount + SplitTabName(1)
PropAPasteCount = SplitTabName(1)
End If
If SplitTabName(2) <> "0" Then
'Set PropRangeA = Range("A" & PropACount)
'MsgBox PropRangeA
'Set PropRangeJ = Range("J" & SplitTabName(2))
PropAPasteCountRange = "A" & PropAPasteCount
'Sheets("PropFiltered").Select
Set CombinedPropRange = ThisWorkbook.Worksheets ("PropFiltered").Range("A" & PropACount & ":J" & SplitTabName(2))
CombinedPropRange.Copy
Sheets("SplitTabName(0)").Select
ThisWorkbook.Worksheets(SplitTabName(0)).Cells(PropAPasteCountRange).Select
ActiveSheet.Paste
PropACount = PropACount + SplitTabName(2)
End If
Next i
End

Resources