How to integrate a Loop

[sophieschrit]

Hey guys,

I'm trying to handle Error message while running my macro. So what I want to do is if there is a error while running the macro on a specific section, I want the Macro closes down the file and continues with the next one.
So I created a code and now I got the Compile Error: Do without Loop and I figured out it means I need to integrate another Loop here as well. But I'm not sure which is the best way. I hope somebody has a massive knowledge of Loops and can help me : pray2:
Thank's a million for helping


On Error GoTo 1
Set Rng1 = Range(Range("C9"), Range("C9").End(xlDown))
Rng1.TextToColumns DataType:=xlDelimited, FieldInfo:=Array(1, 4)
Rng1.Offset(, 1).TextToColumns DataType:=xlDelimited, FieldInfo:=Array(1, 4)

Exit Sub
1:
Application.PrintCommunication = True
ActiveWorkbook.SaveAs Application.Substitute(strErrorVerz & ActiveSheet.Range("B6").Text, ".csv", "") & ".xlsx", FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close SaveChanges:=False
strDateiname = Dir
End Sub

[Paul_Hossler]

Not sure if this will help, but possibly a structure like this will iterate through the files in a folder

It uses a Do While / Loop to go through all the files, but On Error Goto NextFile to close the Active WB

Depending on the error, you can use Err.Number to very specific error handling





Option Explicit
Sub demo()
Dim Rng1 As Range
Dim strDateiname As String, strErrorVerz As String

strDateiname = Dir("c:\users\me\foldernamewithfiles")

Do While Len(strDateiname) > 0
On Error GoTo NextFile
Set Rng1 = Range(Range("C9"), Range("C9").End(xlDown))
Rng1.TextToColumns DataType:=xlDelimited, FieldInfo:=Array(1, 4)
Rng1.Offset(, 1).TextToColumns DataType:=xlDelimited, FieldInfo:=Array(1, 4)

NextFile:

On Error Resume Next
Application.PrintCommunication = True
ActiveWorkbook.SaveAs Application.Substitute(strErrorVerz & ActiveSheet.Range("B6").Text, ".csv", "") & ".xlsx", FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close SaveChanges:=False

strDateiname = Dir

Loop
End Sub

[mikerickson]

If you put RESUME at the end of your error routine, execution will return to the point where the error occurred.

I don't see any loop in the OP code, which makes it hard to advise.

[sophieschrit]

Hi thank you very much for the reply. I'm going to try if your code works for me, I'll let you know :)
And I already have a loop in my macro it's in the beginnig because I have a folder of files and I kind of want him to run over all of them. I just was confused if I need to integrate a loop at this bit as well. Or how I can tell him after closing the file down because of an error to start with the next.
Thank you very much for all the help

[sophieschrit]

Maybe it helps to see the whole macro;


Sub weekly()

Dim strVerzeichnis As String
Dim strDatei As String
Dim strTyp As String
Dim strDateiname As String
Dim strErrorVerz As String
Dim strZielVerz As String

strTyp = "*.csv"
Application.ScreenUpdating = False
strVerzeichnis = "C:\Users\Sophie\Documents\Sophie Schrittenloher\new weeklysettlement\input"
strZielVerz = "C:\Users\Sophie\Documents\Sophie Schrittenloher\new weeklysettlement\output"
strErrorVerz = "C:\Users\Sophie\Documents\Sophie Schrittenloher\new weeklysettlement\error"
strDateiname = Dir(strVerzeichnis & strTyp)
Do While strDateiname <> ""

Workbooks.Open Filename:=strVerzeichnis & strDateiname
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1)), TrailingMinusNumbers:= _
True
'{{{Arrange Columns}}}


Rows("1:1").Select
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Selection.Insert Shift:=xlDown
Columns("A").EntireColumn.Delete
Columns("F").EntireColumn.Delete
Columns("F").EntireColumn.Delete
Columns("G").copy
Columns("J").Select
ActiveSheet.Paste
Columns("I").copy
Columns("G").Select
ActiveSheet.Paste
Columns("N").copy
Columns("C").Select
ActiveSheet.Paste
Columns("I").EntireColumn.Delete
Columns("J").EntireColumn.Delete
Columns("J").EntireColumn.Delete
Columns("K").EntireColumn.Delete
Columns("N").EntireColumn.Delete
Columns("M").EntireColumn.Delete
Range("F9:I9").Select
Range(Selection, Selection.End(xlDown)).Select
With Selection
.HorizontalAlignment = xlRight
End With


'~~~creating the header~~~
Range("A2").Select
ActiveCell.FormulaR1C1 = "payleven Ltd"
Range("A3").Select
ActiveCell.FormulaR1C1 = "Weekly Settlemtn Overview September 2015"
Range("A4").Select
ActiveCell.FormulaR1C1 = "Merchant ID"
Range("A5").Select
ActiveCell.FormulaR1C1 = "Company Name"
Range("A6").Select
ActiveCell.FormulaR1C1 = "Date"


ActiveSheet.Columns("A").AutoFit


Range("B4") = Range("K9")
Range("B5") = Range("L9")


ActiveSheet.Columns("B").AutoFit


Range("B4:B5").Select
With Selection
.HorizontalAlignment = xlLeft
End With


Columns("K:L").EntireColumn.Delete


'++++++sort the data++++++++
Range("A8:J8").Select
Selection.AutoFilter
ActiveSheet.AutoFilter.sort.SortFields.Add Key:=Range("J8"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal


With ActiveSheet.AutoFilter.sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Selection.AutoFilter


'###Change String do Date from PayoutDate and TransactionDate###


Set Rng1 = Range(Range("C9"), Range("C9").End(xlDown))
Rng1.TextToColumns DataType:=xlDelimited, FieldInfo:=Array(1, 4)
Rng1.Offset(, 1).TextToColumns DataType:=xlDelimited, FieldInfo:=Array(1, 4)
On Error GoTo NextFile

'On Error GoTo 1
'Set Rng1 = Range(Range("C9"), Range("C9").End(xlDown))
'Rng1.TextToColumns DataType:=xlDelimited, FieldInfo:=Array(1, 4)
'Rng1.Offset(, 1).TextToColumns DataType:=xlDelimited, FieldInfo:=Array(1, 4)

'Exit Sub
'1:
'Application.PrintCommunication = True
'ActiveWorkbook.SaveAs Application.Substitute(strErrorVerz & ActiveSheet.Range("B6").Text, ".csv", "") & ".xlsx", FileFormat:=xlOpenXMLWorkbook
'ActiveWorkbook.Close SaveChanges:=False
'strDateiname = Dir
NextFile:
On Error Resume Next
Application.PrintCommunication = True
ActiveWorkbook.SaveAs Application.Substitute(strErrorVerz & ActiveSheet.Range("B6").Text, ".csv", "") & ".xlsx", FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close SaveChanges:=False
strDateiname = Dir

'@@@@filter data from monday to friday every week@@@@

Dim EndDate
EndDate = Application.InputBox("Please insert End Date", "END DATE", Format(Date, "dd/mm/yyyy"), , , , , 2)
EndDate = CLng(CDate(EndDate))
With ActiveSheet
.Name = "Settlement Overview"
.Range("A8").AutoFilter Field:=4, Criteria1:=">=" & EndDate - 4, Operator:=xlAnd, Criteria2:="<=" & EndDate
End With

'&&&Copy the filtered data in new sheet&&&
Dim WS As Worksheet
Set WS = Sheets.Add


Worksheets("Settlement Overview").Select
Range("A8:J8").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.copy Worksheets("Sheet1").Range("A1")
Application.CutCopyMode = False


'&&&clear data from first sheet&&&


Worksheets("Settlement Overview").Select


Range("A8").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Cells.AutoFilter
Range("A8").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.clear


'&&&copy the filtered data back&&&


Sheets("Sheet1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.copy
Sheets("Settlement Overview").Select
Range("A8").Select
ActiveSheet.Paste
Range("A8").Select

'&&&delete 2nd sheet&&&


Sheets("Sheet1").Select
ActiveWindow.SelectedSheets.Delete


'{{{sums}}}


Range("F9:I9").Select
Range(Selection, Cells(Rows.Count, Selection.Column).End(xlUp)).Select
Selection.NumberFormat = "[$£-809]#,##0.00"
Range("E9:I9").Select
Range(Selection, Cells(Rows.Count, Selection.Column).End(xlUp)).Select
On Error Resume Next
For Each Cell In Selection
Cell.Value = Cell.Value * 1
Next
On Error GoTo 0
Range("F9:I9").Select
Range(Selection, Cells(Rows.Count, Selection.Column).End(xlUp)).Select
Selection.NumberFormat = "[$£-809]#,##0.00"
Dim NextRow As Long
NextRow = Range("E" & Rows.Count).End(xlUp).Row + 1
Range("F" & NextRow & ":I" & NextRow).Formula = "=SUM(F9:F" & NextRow - 1 & ")"
Range(Selection, Cells(Rows.Count, Selection.Column).End(xlUp)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With


'$$$Layout$$$
Columns("J:J").EntireColumn.AutoFit
Columns("I:I").EntireColumn.AutoFit

Range("A8:J8").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark2
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("A8").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Font.Bold = True
Range("A2").Select
Selection.Font.Bold = True

Range("A3").Select

Range("A4").Select
Selection.Font.Bold = True

Range("A5").Select
Selection.Font.Bold = True

Range("A6").Select
Selection.Font.Bold = True

Range("A2").Select
With Selection.Font
.Color = -4746736
.TintAndShade = 0
End With
Range("A2").Select
With Selection.Font
.Name = "Helvetica"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.Color = -4746736
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Selection.Font.Bold = True
Range("A3:A6").Select
With Selection.Font
.Color = -11782104
.TintAndShade = 0
End With
Range("A1:A8").Select
Range(Selection, Selection.End(xlToRight)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("L8").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With




Range("B4:B6").Select

With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

Range("F8").Select
ActiveCell.FormulaR1C1 = "Amount"
Range("A8:I8").Select
Range("I9").Activate
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark2
.TintAndShade = 0
.PatternTintAndShade = 0
End With


Range("A8:J8").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark2
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("A8:J8").Select
Range(Selection, Cells(Rows.Count, Selection.Column).End(xlUp)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThick
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A8:J8").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("J8").Select
ActiveCell.FormulaR1C1 = "Batch No."
Range("I8").Select
ActiveCell.FormulaR1C1 = "Refunds"
Columns("B:J").EntireColumn.AutoFit

Range("B6") = Now

'===Print option ===

Application.PrintCommunication = True
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = ""
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.75)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With

Application.PrintCommunication = True
ActiveWorkbook.SaveAs Application.Substitute(strZielVerz & ActiveSheet.Range("B6").Text, ".csv", "") & ".xlsx", FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close SaveChanges:=False
strDateiname = Dir
Loop


End Sub

[SamT]

Maybe it helps to see the whole macro;
Actually, it doesn't. That Macro just grew and grew without planning, making it very extremely hard to decipher.

I suggest that you:



Record a Macro Names ConvertAndDeleteColumnA

Wherein you perform the Text To columns and them delete Column A


Record another Macro Named CompleteHeaders

Where in you Insert the Rows, Label the Header Cells and perform all the (Range X = Range Y)'s


Record another Macro Named AllCopyAndPastes

Wherein you perform ALL remaining copying and pasting.


Record similar Macros with specific Names for any other work that can be done before Deleting excess columns
Record Another Macro named DeleteExcessColumns

Wherein you delete the columns from Right to Left



Record yet more Macros named appropriately

Wherein you perform all other operations that could not be done until after the Column Deletions. (ave, Close, Etc)


Edit all those Macros with a comment indicating Workbook and Worksheet they are working on.


That takes care of the first half of your code.

For the rest of your code, the part that operates on the "Settlement Overview" Sheet, do the same break down and recording separate appropriately named macros for each step. Repeat for sheet1.

When you've done that, we will help you convert those Recorded Macros into proper Procedures and your main loop will look like

strDateiname = Dir(strVerzeichnis & strTyp)
Do While strDateiname <> ""

Workbooks.Open Filename:=strVerzeichnis & strDateiname

ConvertTextToColumns strDateiname
ArrangeColumns strDateiname
'Next Step
'Next step
'Etc
strDateiname = Dir
loop

Application.PrintCommunication = True
ActiveWorkbook.SaveAs Application.Substitute(strZielVerz & ActiveSheet.Range("B6").Text, ".csv", "") & ".xlsx", FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close SaveChanges:=False

End Sub

Each of the Macros we convert to proper Procedures will look like

This sub will work to replace the The Macro as is.

Private Sub ConvertColumnA(wkbName As String)

With Workbooks(wkbName).Sheets(1) 'Assumes only one sheet in Workbook.
Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1 _
), Array(14, 1), Array(15, 1), Array(16, 1), Array(17, 1)), _
TrailingMinusNumbers:=True

.Columns("A:A").Delete
End With

End Sub

This Sub will will not work with the Suggested Macros above, because it is before all column Deletions are finished. But it is a good example of a (partial) Macro that has been converted to a proper Procedure.

Private Sub ArrangeColumns(wkbName As String)
Dim DeleteRows As Variant
Dim Rw As Long

'This array may be wrong. I had to mentally add deleted Columns in my head.
'Note that it is in Reverse Column order
'and is developed before any Rows were deleted
DeleteRows = Array("P:Q", "K:M", "G:H", "A")

With Workbooks(wkbName).Sheets(1)
.Rows("1:7").Insert
Columns("J").Copy Columns("M")
Columns("L").CopyColumns ("J")
Columns("Q").Copy Columns("F")

For Rw = 0 To 3
Rows(DeleteRows(Rw)).Delete
Next Rw

Range(Range("F9:I9"), Range("F9:I9").End(xlDown)).HorizontalAlignment = xlRight
End With
End Sub


BTW, Please use a comment to indicate the English meaning of German words. Thanks.

Dim strVerzeichnis As String '(directory)
Dim strDatei As String '(File)
Dim strTyp As String ' Extension String
Dim strDateiname As String '(File Name)
Dim strErrorVerz As String 'Error Dir)
Dim strZielVerz As String '(Target Dir)

[sophieschrit]

Thank you all very much for your replies.