More efficient/effective solution needed for loop

[scottiedog45]

Hello!

You'll be able to tell by this post, but I'm a beginner at VBA programing. I wrote the following code with this intention: One workbook with two worksheets. The first worksheet has a list of names, and the second sheet is a formatted document. The code would go to the first name in the list of names in the first sheet, bring that name to the second sheet, format the name in the second sheet, and save the second sheet as a stand alone document to a specified path that included the copied name from the first sheet in the file path. Then the code would go back to the list of names in the first sheet, move to the next name in the list, and repeat until it had cycled through each name on the list.

Unfortunately I had a hard time figuring out how to make the code go back to the first list, and move down the list to repeat the process for each name in the least. I've come up with the inelegant solution to delete a row from the top of the name list as the code cycled through it, and move the rest of the names in the list up one cell. This means the code can keep referring to Range("A1") of the first list as the cell becomes repopulated with the information that was one row beneath it, instead of actually going down the list cell by cell.

While the endgame of the workflow has been achieved, I end up with the first list of names completely erased.

Would someone perhaps have an alternative solution, that would cycle down through the name list, instead of obliterating it?

tldr: What would the code be to perform a function on each cell in a list of cells, moving down the list?

Thanks in advance for your help and advice.

Here's my current code:

Sub Macro1()
'
' Macro1 Macro
'
 
'
   Do Until IsEmpty(ActiveCell)
    Dim Name As String
    Range("A1").Select
    Selection.Copy
    Name = Range("A1")
    Sheets("Itinerary").Select
    Range("E2").Select
    Selection.PasteSpecial Paste:=xlFormulas, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    
    ActiveWorkbook.SaveAs Filename:= _
        "/Users/scottotoole/Desktop/ASO/17-18/Itineraries in Limbo/" & Name & ".xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    Sheets("Sheet1").Select
    Sheets("Sheet1").Name = "Sheet1"
    Rows(1).Delete
    Range("A1").Select
 
    Loop
 
End Sub
[code]

 

[JLGWhiz]

See if this does what you want. I change your variable from 'Name' to 'Nm' because Name is a keyword with specific meaning in VBA and using it as a variable can confuse the compiler causing undesirable results.

Sub newMacro1()
 '
 ' Macro1 Macro
 '
 '
 
 Dim Nm As String
 With Sheets(1) 'Edit sheet name
    For Each c In .Range("A1", Cells(Rows.Count, 1).End(xlUp)) 'This initiates a loop for the list
        Nm = c.Value
        Sheets("Itinerary").Range("E2") = Nm
        Sheets("Itinerary").Copy
        ActiveWorkbook.SaveAs Filename:= _
        "/Users/scottotoole/Desktop/ASO/17-18/Itineraries in Limbo/" & Nm & ".xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWorkbook.Close False
    Next
 End With
 End Sub

 

[dmt32]

Hi,
welcome to forum

Untested but see if following update to your code does what you want

Sub Macro1()
'
' Macro1 Macro
'


    Dim rng As Range, cell As Range
    Dim Folder As String


'folder to save workbook
    Folder = "/Users/scottotoole/Desktop/ASO/17-18/Itineraries in Limbo/"
'file names stored in sheet1
    With ThisWorkbook.Sheets("Sheet1")
        Set rng = .Range(.Range("A1"), .Range("A" & .Rows.Count).End(xlUp))
    End With


    Application.ScreenUpdating = False
    For Each cell In rng.Cells
     If Len(cell.Value) > 0 Then
        With Sheets("Itinerary")
            .Range("E2").Value = cell.Value
'copy sheet
            .Copy
        End With
 
        With ActiveWorkbook
'change tab name
            .Sheets(1).Name = Left(cell.Value, 31)
'save workbook
            .SaveAs Filename:=Folder & cell.Value & ".xlsx", _
                FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
'close file
            .Close False
        End With
    End If
    Next cell
'delete filenames
    rng.ClearContents
    Application.ScreenUpdating = True


End Sub

Dave

 

[scottiedog45]

This worked! Thank you so much for your help!

 

[JLGWhiz]

This worked! Thank you so much for your help!

You're welcome,
regards, JLG