We help IT Professionals succeed at work.

Copy rows by VBA

Andreas Hermle
on
Dear Experts:

I wonder whether the following task can be performed by running a macro:

The macro is to loop through data records.

Whenever it hits an entry in Column C formatted Verdana 16, the macro is to copy that row along with subsequent rows until the macro hits another entry in Column C (formatted With Verdana 16) and paste these rows into its own worksheet. The macro is to loop until the last entry in Column C has been found (formatted with Verdana 16pt).

I have attached a sample file with a couple of examples and instructions/explanations.

Help is much appreciated.Thank you very much in advance.

Regards, Andreas

Copy-rows-VBA.xlsx
Comment
Watch Question

That would certainly be possible !

place this code in the vba code section of sheet1:

Sub process()
Dim row As Range
Dim dst As Worksheet

    startrow = -1
    For Each row In Me.UsedRange.Rows
        'Me.Select
        'row.Select
        If row.Cells(3).Font.Name = "Verdana" And row.Cells(3).Font.Size = 16 Then
            '-- start a new section, add a destination worksheet
            Set dst = Worksheets.Add
            row.Copy dst.Range("A1")
        Else
            '-- add data to destination sheet
            If Not dst Is Nothing Then
                row.Copy dst.Range("A" & dst.UsedRange.Rows.Count + 1)
            End If
        End If
    Next row

End Sub

Open in new window

Copy-rows-VBA.xlsm
RyanProject Engineer, Electrical
CERTIFIED EXPERT

Commented:
Public Sub CopyVals()
Dim i As Integer
Dim firstRow As Integer

firstRow = -1
For i = 2 To Range("C65000").End(xlUp).Row
    If Range("C" & i).Font.Name = "Verdana" Then
        If firstRow > 0 Then
            CopyRange2NewSh firstRow, i - 1
        End If
        firstRow = i
    End If
Next i
CopyRange2NewSh firstRow, i
End Sub

Private Sub CopyRange2NewSh(firstRow As Integer, LastRow As Integer)
    Dim sh As Worksheet
    Set sh = Sheets.Add
    sh.Name = Range("C" & firstRow).Text
    Range("A" & firstRow & ":D" & LastRow).Copy sh.Range("A1")
End Sub

Open in new window

Andreas HermleTeam leader

Author

Commented:
Hi Mr Bullwinkle,

thank you very much for your time taken and your professional support. I am afraid to tell you that your code throws an error message on line 20, runtime error 1004.

It maybe only a minor error for you to correct. Since akoster happened to be a bit quicker to answer, I will award the points to him. Nevertheless thank you very much for your great job. Your code looks very sophisticated, too.

Regards, Andreas
Andreas HermleTeam leader

Author

Commented:
Hi akoster,

thank you very much for your great job. Works like a charm. There is one thing I would like to get added to the code if possible/feasible.

The headings ...
Art-No      Description_1      Description_2      Graphic_1

should be copied to the very top of each added worksheet as well.

That would be great. Thank you very much for your support.

Regards, Andreas
Project Engineer, Electrical
CERTIFIED EXPERT
Commented:
That line of code renames the sheet to the header. I expect you're getting it because theres already a sheet with that name (you've run the code twice).  You can delete the line, or delete the sheets that were created in a previous run.  (There's ways to check for this, but it was just a feature I threw in).

Here's corrected code, with the header row copied.
Public Sub CopyVals()
Dim i As Integer
Dim firstRow As Integer

firstRow = -1
For i = 2 To Range("C65000").End(xlUp).Row
    If Range("C" & i).Font.Name = "Verdana" Then
        If firstRow > 0 Then
            CopyRange2NewSh firstRow, i - 1
        End If
        firstRow = i
    End If
Next i
CopyRange2NewSh firstRow, i
End Sub

Private Sub CopyRange2NewSh(firstRow As Integer, LastRow As Integer)
    Dim sh As Worksheet
    Set sh = Sheets.Add
    'sh.Name = Range("C" & firstRow).Text
    Range("A" & firstRow & ":D" & LastRow).Copy sh.Range("A2")
    range("A1:D1").copy sh.Range("A1")
End Sub

Open in new window

Sub process()
Dim row As Range
Dim dst As Worksheet

    startrow = -1
    For Each row In Me.UsedRange.Rows
        'Me.Select
        'row.Select
        If row.Cells(3).Font.Name = "Verdana" And row.Cells(3).Font.Size = 16 Then
            '-- start a new section, add a destination worksheet
            Set dst = Worksheets.Add
            row.Copy dst.Range("A1")
            dst.Range("A2") = "Art-No"
            dst.Range("B2") = "Description_1"
            dst.Range("C2") = "Description_2"
            dst.Range("D2") = "Graphic_1"
        Else
            '-- add data to destination sheet
            If Not dst Is Nothing Then
                row.Copy dst.Range("A" & dst.UsedRange.Rows.Count + 1)
            End If
        End If
    Next row

End Sub

Open in new window

if you want you can also change
            row.Copy dst.Range("A1")
            dst.Range("A2") = "Art-No"
            dst.Range("B2") = "Description_1"
            dst.Range("C2") = "Description_2"
            dst.Range("D2") = "Graphic_1"
to
            dst.Range("A1") = "Art-No"
            dst.Range("B1") = "Description_1"
            dst.Range("C1") = "Description_2"
            dst.Range("D1") = "Graphic_1"
            row.Copy dst.Range("A2")
Andreas HermleTeam leader

Author

Commented:
Thank you very much for your superb support. I will test it this evening and let you know.

Thank you very much. Regards, Andreas
Andreas HermleTeam leader

Author

Commented:
Dear both:

The first code of akoster works well, the second one gives erroneous results.
Mr Bullwinkle's second one does not throw any error message anymore but does not perform any action at all save adding worksheets. Maybe it is my machine that it is not working well.

Since akoster's first code is perfectly good for me (the required tweak is not that important), I could award points right away to akoster or if you wish you could do some troubleshooting at your codes again. It is up to.

Again, thank you very much for your overwhelming and superb support. I really appreciate it.

Regards, Andreas
andreas, which errors do you perceive in the results of the second code ?
RyanProject Engineer, Electrical
CERTIFIED EXPERT

Commented:
I just opened your original spreadsheet, pressed Alt f11 to bring up code, pasted the code from post #a38294048 (my last version) , ran the code, and it made sheets, and puts in the data.  Though the column widths aren't ideal.

Akoster's last version of code works with nearly identical results to mine too, akoster is copying whole rows, I just copied A:E.

If you're getting errors its something altered that we're not aware of.

There's certainly a lot of features that could be added, and this question could go on forever.

I would suggest just splitting the points, and if you have additional requests, post a new question for those features.

Also notice we've both approached the solution with slightly different methods, so it's a nice chance to compare ways to approach coding, though there certainly are vastly different ways from what we've offered.
Andreas HermleTeam leader

Author

Commented:
Hi bullwinkle,

ok, you were right, I also opened the original file and your code works just fine. I must have inadvertently altered something, I guess. Sorry about this mishap.

Anyhow, as you suggested, splitting points is fair.

Again, thank you very much you two for this superb and professional help. I really appreciate it.

Regards, Andreas

Explore More ContentExplore courses, solutions, and other research materials related to this topic.