Loop Through Rows & Copy Each Row To New Workbook

Jon Field · Aug 27th 2008

Hi,

I have some data for my students in the range D2:G251, where each row is a different student.

I need to write a macro that, if there is an 'x' against their name in column D, will copy the data in columns E-G into range A1:B500 and copy that range into a new workbook and save the workbook with the students name.

The following code does this for the first row, but I don't know how to write a loop (or whatever) to make it do it for the other 249 rows.

Code

Private Sub CreateNewSheets_Click()


Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Sheets("Template")
Dim Rng1 As Range
Set Rng1 = ws1.Range("A1:B504")
varPath = ThisWorkbook.Path




If ws1.Range("D2") = "x" Then


ws1.Activate
ws1.Range("e2:g2").Copy
ws1.Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Rng1.Copy
Workbooks.Add
ActiveSheet.Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.SaveAs varPath & "\Student Data Files\" & ActiveSheet.Range("B1") & ".xls"
ActiveWorkbook.Close


Else


End If




End Sub

Display More

Any help you could give would be greatly appreciated.

Thanks,

Jon

**Ger Plante** · Aug 27th 2008

Re: Create Workbooks From List And Import Data

Jon, I cant understand how you managed the get other code working, and you couldnt get a loop to work, but anyway, here is the simplest loop structure ("for" loop) which goes from row 2 to row 251. I have no idea if the rest of your code works....

Code

Option Explicit


Private Sub CreateNewSheets_Click()
     
    Dim ws1 As Worksheet
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Dim Rng1 As Range
    Dim varPath As Variant
    Dim lLoop As Long
    Set Rng1 = ws1.Range("A1:B504")
    varPath = ThisWorkbook.Path
     
    For lLoop = 2 To 251 'first row of data to last row.
        If ws1.Cells(lLoop, 4).Value = "x" Then '4 = Column D
            ws1.Activate
            ws1.Range("e2:g2").Copy
            ws1.Range("B1").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            Rng1.Copy
            Workbooks.Add
            ActiveSheet.Range("A1").Select
            Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            ActiveSheet.SaveAs varPath & "\Student Data Files\" & ActiveSheet.Range("B1") & ".xls"
            ActiveWorkbook.Close
             
        Else
             
        End If
     Next lLoop
     
End Sub

Display More

Ger

Jon Field · Aug 27th 2008

Re: Create Workbooks From List And Import Data

Thanks Ger.

I have done as you suggested but it seems to always copy the data from e2:g2.

What I need it do is when it checks the 'x' in for example D4 to then copy the data from E4:G4 and so on

Any ideas?

Cheeky Charlie · Aug 27th 2008

Re: Loop Through Rows and Copy Data

To be clear, you want 250 workbooks, each with one line of data?

Jon Field · Aug 27th 2008

Re: Loop Through Rows and Copy Data

What I need is, depending on whether a student has an "x" by his/her name to copy some data about them into a range containing a load of assessment statements and then copy this range into new workbook with an appropriate name.

What I have written will do this for the first student but not the other 249.

What Ger has written checks whether the x is there but then only copies over the data from the first row.

So in short Yes...ish.

**Ger Plante** · Aug 27th 2008

Re: Loop Through Rows and Copy Data

Jon - what I gave you was a loop structure (a for loop) to go through each row. Given the amount of code you had already written, I thought you would give a shot at using the loop structure in the code...

In any case,

Code

Option Explicit
 
Private Sub CreateNewSheets_Click()
     
    Dim ws1 As Worksheet
    Set ws1 = ThisWorkbook.Sheets("Sheet1")
    Dim Rng1 As Range
    Dim varPath As Variant
    Dim lLoop As Long
    Set Rng1 = ws1.Range("A1:B504")
    varPath = ThisWorkbook.Path
     
    For lLoop = 2 To 251 'first row of data to last row.
        If ws1.Cells(lLoop, 4).Value = "x" Then '4 = Column D
            ws1.Activate
            ws1.Range("e" & lLoop & ":g" & lLoop).Copy
            ws1.Range("B1").Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            Rng1.Copy
            Workbooks.Add
            ActiveSheet.Range("A1").Select
            Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            ActiveSheet.SaveAs varPath & "\Student Data Files\" & ActiveSheet.Range("B1") & ".xls"
            ActiveWorkbook.Close
             
        Else
             
        End If
    Next lLoop
     
End Sub

Display More

So above, instead of copying the same row over and over again, it is copying using the row referenced in the variable lLoop.

But again, I cant test this fully, so hopefully this will be closer to what you are trying to do-ish.

Ger

Jon Field · Aug 27th 2008

Re: Loop Through Rows and Copy Data

That is awesome thanks Ger...it works perfectly. My apologies, I should have made it clearer, I know next to nothing about vba I am just good at adapting what I find on Ozgrid but this time there was nothing quite close enough and internet tutorials were not clear enough. Anyway, thanks again, and have a good evening,

Jon

PS. I will reference you in the code so that anyone checking it knows where it came from

Loop Through Rows & Copy Each Row To New Workbook

Participate now!

Share