Macro saved as CSV stops Macro from working - excel

I'm working on a Macro that makes several CSV files from a certain area while applying a filter. There are two issues.
The workbook will be saved as a file-format retrieved from it's name (cell B15 and the word 'Week')
I cannot find a way to loop this Macro until Cell B15 is empty.
Can anyone help? Thanks in advance.
Example wrong format:
Sub CSVMaker()
'
' CSVMaker Macro
'
'
ActiveSheet.Range("$A$17:$M$240000").AutoFilter Field:=2, Criteria1:="<>"
Range("A18:B18").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets.Add.Name = Range("A10").Value & "." & Range("A7").Value & "." & "Week" & Range("B15").Value
ActiveSheet.Paste
Application.CutCopyMode = False
Application.DisplayAlerts = False
ActiveSheet.Copy
ActiveWorkbook.SaveAs Filename:=ActiveSheet.Name, FileFormat:=xlCSV, CreateBackup:=True
ActiveWorkbook.Close
Application.DisplayAlerts = True
Sheets("Input").Select
Columns("B:B").Select
Range("B6").Activate
Selection.Delete Shift:=xlToLeft
End Sub

So finally the answer is the filename needs a correct extension like Filename:=ActiveSheet.Name & ".csv".
And I recommend to avoid .Select and do the following:
Option Explicit
Public Sub CSVMaker()
Dim ws As Worksheet
Set ws = ActiveSheet 'better ThisWorkbook.Worksheets("your-sheet-name")
ws.Range("$A$17:$M$240000").AutoFilter Field:=2, Criteria1:="<>"
ws.Range("A18:B18", ws.Range("A18:B18").End(xlDown).End(xlDown)).Copy
Dim SheetName As String
SheetName = ws.Range("A10").Value & "." & Range("A7").Value & "." & "Week" & Range("B15").Value
ThisWorkbook.Sheets.Add.Name = SheetName
ThisWorkbook.Sheets(SheetName).Paste
Application.CutCopyMode = False
Application.DisplayAlerts = False
ThisWorkbook.Sheets(SheetName).Copy
ActiveWorkbook.SaveAs Filename:=SheetName & ".csv", FileFormat:=xlCSV, CreateBackup:=True
ActiveWorkbook.Close
Application.DisplayAlerts = True
ThisWorkbook.Sheets("Input").Columns("B:B").Delete Shift:=xlToLeft
End Sub

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

Looping a recorded macro in Excel

I am not familiar with VBA so please forgive the simplicity of this question. I have a recorded macro which selects, opens then saves a file from a hyperlink in one of my columns. I just want to make a loop to repeat this macro down all of the rows in the worksheet which have data in them. Below is the code for the recorded macro, thank you all for your assistance.
Sub Extract()
'
'Extract Macro
'
'
Range("D2").Select
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
Workbooks.Open Filename:= _
"https://channele.corp.etradegrp.com/communities/teams02/performance-monitoring/TPEF%20Library/A2Consulting_Tech_5650_VSAF.xlsm"
ActiveWindow.Visible = False
Windows("A2Consulting_Tech_5650_VSAF.xlsm").Visible = True
ChDir "O:\Procurement Planning\QA"
ActiveWorkbook.SaveAs Filename:= _
"O:\Procurement Planning\QA\Copy of A2Consulting_Tech_5650_VSAF.xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
ActiveWindow.Close
End Sub
Something like this might work already:
Sub Extract()
Dim RngTarget As Range
Dim StrFileName As String
Set RngTarget = Range("D2")
Do Until RngTarget.Value = ""
RngTarget.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
Workbooks.Open Filename:=RngTarget.Value
StrFileName = Split(RngTarget.Value, "/")(UBound(Split(RngTarget.Value, "/")))
Windows(StrFileName).Visible = True
Workbooks(StrFileName).SaveAs Filename:="O:\Procurement Planning\QA\Copy of " & Split(StrFileName, ".")(0) & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, _
CreateBackup:=False
Workbooks(StrFileName).Close
Set RngTarget = RngTarget.Offset(1, 0)
Loop
End Sub

Excel macro loops for taking values from a range of cells and filenaming

I have an Excel macro (own recorded), which does following:
in the column A (A1-A90) are placed different formulas. Formula calculation is set to manual.
The macro
copies formula from A1
creates new file
pastes formula into A1 of newly created file
calculates the formel
saves the file
The macro code is:
Sub Makro1()
'
' Makro1 Makro
'
Windows("macrotest.xlsx").Activate
Range("A1").Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
Calculate
ActiveWorkbook.SaveAs Filename:= _
"Z:\Mappe1.csv", FileFormat:=xlCSV, _
CreateBackup:=False
Windows("macrotest.xlsx").Activate
Range("A2").Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
Calculate
ActiveWorkbook.SaveAs Filename:= _
"Z:\Mappe2.csv", FileFormat:=xlCSV, _
CreateBackup:=False
Windows("macrotest.xlsx").Activate
Range("A3").Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
Calculate
ActiveWorkbook.SaveAs Filename:= _
"Z:\Mappe3.csv", FileFormat:=xlCSV, _
CreateBackup:=False
End Sub
I have more then 100 formulas, so it would be nice to have two loops in the macro instead of paste 100 code snippets into macro code:
one loop would take formulas from the range A1-A90 one by one to paste into created files
second loop would give forthcoming file names on saving files (not important, which names - 1.csv to 100.csv is fully enough).
Please point me to right loops.Thanks.
Upd:
Based on advice from Tim Edwards i build up this macro:
Sub MyMacro()
Dim i As Integer, myname As String
myname = ThisWorkbook.Name
For i = 1 To 90
Windows(myname).Activate
Range("A" & i).Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
Calculate
ActiveSheet.Calculate
ActiveWorkbook.SaveAs Filename:= _
"Z:\file" & i & ".csv", FileFormat:=xlCSV, _
CreateBackup:=False
ActiveWorkbook.Close True
Next i
End Sub
But the problem on it is, that the formulas in saved files aren't calculated - i get only the pasted formulas into a1.
Does somebody see the cause, why formulas aren't calculated before saving? I tried all kinds of formula calculation setting - automatic, manual, manual on saving.
Sub Makro1()
Dim i as integer
For i = 1 to 100
Windows("macrotest.xlsx").Activate
Range("A" & i).Copy
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
Calculate
ActiveWorkbook.SaveAs Filename:= "Z:\Mappe" & i & ".csv", FileFormat:=xlCSV, CreateBackup:=False
Next i
End Sub
Make one loop going from 1 to 90.
For i = 1 To 90
Next i
In each iteration:
Get the formula from Cells(i, 1).
Paste into a new workbook and calculate.
Save the workbook as "directory.." + i +".csv".

Excel Macro to Concatenate first and last name sometimes fails

I am a Visual Basic newbie. From hints on the web, I pieced together an Excel macro that does several things, including concatenating first and last name, in a loop, to make a new column with those joined. Half the time it works great, half the time I end up with no space between the first and last name. (In those cases, closing, re-opening, and re-running almost always works.) Is this a timing issue? I'll put in the whole macro but it's the Do While loop near the top that I think is the problem.
Thanks for any help.
Sub WholeThing()
'
' WholeThing Macro
Application.ScreenUpdating = False
ActiveSheet.Name = "original"
Rows("1:1").Delete Shift:=xlUp
Do While ActiveCell <> "" 'Loops until the active cell is blank.
ActiveCell.Offset(0, 0).FormulaR1C1 = _
ActiveCell.Offset(0, 1) & " " & ActiveCell.Offset(0, 2)
ActiveCell.Offset(1, 0).Select
Loop
Application.Wait (Now + TimeValue("0:00:02"))
Sheets.Add After:=Sheets(Sheets.Count)
Sheets.Add After:=Sheets(Sheets.Count)
Sheets.Add After:=Sheets(Sheets.Count)
Sheets.Add After:=Sheets(Sheets.Count)
Sheets.Add After:=Sheets(Sheets.Count)
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("Original").Activate
ActiveWindow.WindowState = xlNormal
Application.CutCopyMode = False
Application.DisplayAlerts = False
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ActiveSheet.Paste Destination:=Worksheets("Sheet6").Range("A1")
Range("D1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
ActiveSheet.Paste Destination:=Worksheets("Sheet6").Range("B1")
Sheets("Original").Activate
ActiveWindow.WindowState = xlNormal
Application.CutCopyMode = False
Application.DisplayAlerts = True
Columns("Y:Y").Copy
ActiveSheet.Paste Destination:=Worksheets("Sheet2").Range("A1")
Columns("Z:Z").Copy
ActiveSheet.Paste Destination:=Worksheets("Sheet3").Range("A1")
Columns("AA:AA").Copy
ActiveSheet.Paste Destination:=Worksheets("Sheet4").Range("A1")
Columns("AB:AB").Copy
ActiveSheet.Paste Destination:=Worksheets("Sheet5").Range("A1")
Application.DisplayAlerts = False
Sheets("Sheet5").Activate
ActiveWorkbook.SaveAs Filename:="Y:\Addrs_DL", FileFormat:=xlCSV, _
CreateBackup:=False
Sheets("Sheet4").Activate
ActiveWorkbook.SaveAs Filename:="Y:\Addrs_D", FileFormat:=xlCSV, _
CreateBackup:=False
Sheets("Sheet3").Activate
ActiveWorkbook.SaveAs Filename:="Y:\Addrs_SL", FileFormat:=xlCSV, _
CreateBackup:=False
Sheets("Sheet2").Activate
ActiveWorkbook.SaveAs Filename:="Y:\Addrs_S", FileFormat:=xlCSV, _
CreateBackup:=False
Sheets("Sheet6").Activate
ChDir "Y:\"
Application.ScreenUpdating = True
ActiveWorkbook.SaveAs Filename:="Y:\NAME-ADR.CSV", FileFormat:=xlCSV, _
CreateBackup:=False
' Application.Quit
' Application.ActiveWindow.Close SaveChanges:=False
' ActiveWorkbook.Close SaveChanges:=False
End Sub
By not using ActiveCell and working with your range directly, you can make your code more stable and more reliable.
Consider something like this (see notes about assumptions on range and cell references).
Dim ws as Worksheet
Set ws = ThisWorkbook.Sheets("original")
With ws
Dim lRow as Long
lRow = .Range("B" & .Rows.Count).End(xlup).Row 'assumes first name in column B
'assumes concatenated name goes in column A, starting at row 1 (and the first and last name are in B and C, respectively
.Range("A1:A" & lRow).FormulaR1C1 = "=RC[1] & "" "" & RC[2]"
'if you want to copy as values you can use this
.Range("A1:A" & lRow).Value = .Range("A1:A" & lRow).Value
End With
You can also work with the same principles of working directly with the object later on in your code, like this:
'lRow would be the last row of data in the column (assumes same row for each column, based on dataset)
ws.Range("Y1:Y" & lRow).Copy Worksheets("Sheet2").Range("A1")
Doing this will save a lot of processing time as copying entire columns is very inefficient if it's not truly needed.
To do the concatenate, I had first to use this to get the number of the last row:
Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
That enabled this loop to do the concatenation:
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("original")
With ws
For i = 1 To LastRow
Cells(i, 1) = Cells(i, 2) & " " & Cells(i, 3)
Next i
Then, for the second block (the "With ws" being still in effect):
Sheets("Original").Activate
Range("Y1:Y" & LastRow).Copy Worksheets("Sheet2").Range("A1")

Excel freezes when recording macro

I have an existing .xlsm file that runs perfectly with all of the macros. The problem is that when I attempt to record another macro, I add a column, press enter, and get the message "Microsoft Excel has stopped responding". I then have to end the process. I am assuming that this has something to do with the existing macro which was imported from Excel 2003 and modified to work for 2010.
Are there any incompatabilities within this macro that could cause this issue?
Sub Auto_Open()
Wbname = ActiveWorkbook.Name ' this needs to be first so the move works properly
fileToOpen = Application.GetOpenFilename("CSV files (*.csv), *.csv", 1, "Select file to open")
If fileToOpen <> False Then
Workbooks.Open (fileToOpen)
End If
sheetname = ActiveSheet.Name
Sheets(sheetname).Select
Sheets(sheetname).Move Before:=Workbooks(Wbname).Sheets(1)
Call Weekly_RTP
End Sub
Sub Weekly_RTP()
'
' Macro recorded 01/12/12 by Robert Gagliardi
'
' This next section (up to call sort_data) is needed until we get the formatting correct.
' Clearing the last rows and adding misc headers will solve the short term problem
' Need this once pivot table is created. Can't have heading row without names in it
Range("L1").Select
ActiveCell.FormulaR1C1 = "Misc"
Range("M1").Select
ActiveCell.FormulaR1C1 = "Misc1"
Columns("N:Z").Select
Selection.ClearContents
Call Sort_data
' concat mui & object to make it easy to find dups use countifs once at excel 2007 or greater
Range("N1").Select
ActiveCell.FormulaR1C1 = "Junk"
Range("N2").Select
ActiveCell.FormulaR1C1 = "=RC[-7]&RC[-5]"
Range("N2").Select
Selection.Copy
' need to find last row using column K2
lastrow = ActiveSheet.Range("K2").End(xlDown).Select
' Selection.Offset(0, 3).Select Moves over 3 cells
Range("N2", Selection.Offset(0, 3)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("C:C").Select
Selection.Insert Shift:=xlToRight
Range("C1").Select
ActiveCell.FormulaR1C1 = "Alerts"
Range("C2").Select
ActiveCell.FormulaR1C1 = "=IF(COUNTIF(R2C[12]:RC15,RC[12])=1,COUNTIF(C[12],RC[12]),"" "")"
Range("C2").Select
Selection.Copy
' need to find last row using column B2 since column C was just added
lastrow = ActiveSheet.Range("B2").End(xlDown).Select
' Selection.Offset(0, 1).Select Moves over 1 cell from last cell in column B
Range("C2", Selection.Offset(0, 1)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Call Create_pivot
Call Save_data
' how to select a range of cells with data in them
' Worksheets(ActiveSheet.Name).Activate
' ActiveCell.CurrentRegion.Select
End Sub
Sub Create_pivot()
Wbname = ActiveWorkbook.Name
' Insert columns to make room for pivot table
Columns("A:I").Select
Selection.Insert Shift:=xlToRight
myData = Sheets(ActiveSheet.Name).[J1].CurrentRegion.Address
mySheet = ActiveSheet.Name & "!"
tableDest = "[" & Wbname & "]" & mySheet & "R1C1"
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
mySheet & myData).CreatePivotTable TableDestination:=tableDest, TableName _
:="RTP_alerts", DefaultVersion:=xlPivotTableVersionCurrent
With ActiveSheet.PivotTables("RTP_alerts").PivotFields("Application")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("RTP_alerts").PivotFields("Object")
.Orientation = xlRowField
.Position = 2
End With
ActiveSheet.PivotTables("RTP_alerts").AddDataField ActiveSheet.PivotTables( _
"RTP_alerts").PivotFields("Alerts"), "Count of Alerts", xlCount
ActiveWorkbook.ShowPivotTableFieldList = False
Application.CommandBars("PivotTable").Visible = False
Columns("G:I").Select
Selection.Delete Shift:=xlToLeft
Range("D2").Select
ActiveCell.FormulaR1C1 = "Owner"
Range("E2").Select
ActiveCell.FormulaR1C1 = "Problem Ticket"
Columns("E:E").ColumnWidth = 13
Range("F2").Select
ActiveCell.FormulaR1C1 = "Comments"
Columns("F:F").ColumnWidth = 48
End Sub
Sub Save_data()
Filename = ActiveWorkbook.Name
Do
Fname = Application.GetSaveAsFilename(Filename, fileFilter:="Excel Files (*.xlsm), *.xlsm")
Loop Until Fname <> False
ActiveWorkbook.SaveAs Filename:=Fname, FileFormat:=52
End Sub
Sub Sort_data()
Columns("A:M").Select
Selection.Sort Key1:=Range("G2"), Order1:=xlAscending, Key2:=Range("I2") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
:=xlSortNormal
Range("A1").Select
End Sub
I experienced the same problem, here's something you can try. Go to start-->run, and type %temp% in the box. This will bring up your temporary files.
Delete all or some of them, restart your computer and try again.

Resources