CODEWITHSUNDEEP
excelvba
Mammolytic
Mammolytic

Reputation: 155

Loop and add one to the range

I have this workbook with 2 sheets, the first sheet has a list of information and the second sheet is a form. I need to go through each line on the first sheet and put that information into the form, and save that sheet as a new workbook and be named from a certain cell. I basically have it all, I just need to put it in a loop and add one to the range every time it loops. Here is what I got, is there a easy way to make it loop and add one to the range. Thanks.

Sub Range_Copy()

   Worksheets("Sheet1").Range("J2").Copy Worksheets("Sheet4").Range("K3:O3")
   Worksheets("Sheet1").Range("K2").Copy Worksheets("Sheet4").Range("E3:H3")
   Worksheets("Sheet1").Range("A2").Copy Worksheets("Sheet4").Range("A1:O1")
   Worksheets("Sheet1").Range("B2").Copy Worksheets("Sheet4").Range("E29:F29")
   Worksheets("Sheet1").Range("C2").Copy Worksheets("Sheet4").Range("G29:H29")
   Worksheets("Sheet1").Range("D2").Copy Worksheets("Sheet4").Range("D7:O7")
   Worksheets("Sheet1").Range("E2").Copy Worksheets("Sheet4").Range("L8:O8")
   Worksheets("Sheet1").Range("F2").Copy Worksheets("Sheet4").Range("D8:G8")
   Worksheets("Sheet1").Range("G2").Copy Worksheets("Sheet4").Range("D9:O9")
   Worksheets("Sheet1").Range("H2").Copy Worksheets("Sheet4").Range("D6:O6")
   Worksheets("Sheet1").Range("I2").Copy Worksheets("Sheet4").Range("A48:O48")

   Application.ScreenUpdating = False
   ActiveSheet.Select
   ActiveSheet.Copy
   ThisFile = Range("A1").Value
   ActiveSheet.SaveAs Filename:="H:\Intern Work\Server List\Server Form List\" & 
   ThisFile & ".xlsx"
   Application.ScreenUpdating = True
   ActiveWorkbook.Close
End Sub

Upvotes: 0

Views: 201

Answers (1)

dwirony
dwirony

Reputation: 5450

Pretty sure this is what you're looking for, however I'm not sure if you're going to hit any snags when trying to save 600 individual files - 

Sub Range_Copy()

Dim i As Long, lastrow As Long
Dim sht As Worksheet, sht2 As Worksheet, newwb As Workbook

Set sht = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = ThisWorkbook.Worksheets("Sheet4")
lastrow = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row

Application.ScreenUpdating = False
Application.DisplayAlerts = False

For i = 2 To lastrow

    sht2.Range("A1:O1").Value = sht.Range("A" & i).Value
    sht2.Range("E29:F29").Value = sht.Range("B" & i).Value
    sht2.Range("G29:H29").Value = sht.Range("C" & i).Value
    sht2.Range("D7:O7").Value = sht.Range("D" & i).Value
    sht2.Range("L8:O8").Value = sht.Range("E" & i).Value
    sht2.Range("D8:G8").Value = sht.Range("F" & i).Value
    sht2.Range("D9:O9").Value = sht.Range("G" & i).Value
    sht2.Range("D6:O6").Value = sht.Range("H" & i).Value
    sht2.Range("A48:O48").Value = sht.Range("I" & i).Value
    sht2.Range("K3:O3").Value = sht.Range("J" & i).Value
    sht2.Range("E3:H3").Value = sht.Range("K" & i).Value

    Set newwb = Workbooks.Add
    sht2.Copy Before:=newwb.Sheets(1)
    newwb.SaveAs Filename:="H:\Intern Work\Server List\Server Form List\" & sht2.Range("A1").Value & ".xlsx"
    newwb.Close False

Next i

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Upvotes: 2

Related Questions