?
Solved

Copy rows by VBA

Posted on 2012-08-13
12
Medium Priority
?
304 Views
Last Modified: 2012-08-20
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
0
Comment
Question by:AndreasHermle
  • 5
  • 4
  • 3
12 Comments
 
LVL 19

Expert Comment

by:Arno Koster
ID: 38292088
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
0
 
LVL 13

Expert Comment

by:Ryan
ID: 38292103
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

0
 

Author Comment

by:AndreasHermle
ID: 38293738
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
0
Concerto's Cloud Advisory Services

Want to avoid the missteps to gaining all the benefits of the cloud? Learn more about the different assessment options from our Cloud Advisory team.

 

Author Comment

by:AndreasHermle
ID: 38293768
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
0
 
LVL 13

Accepted Solution

by:
Ryan earned 1000 total points
ID: 38294048
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

0
 
LVL 19

Assisted Solution

by:Arno Koster
Arno Koster earned 1000 total points
ID: 38295459
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

0
 
LVL 19

Expert Comment

by:Arno Koster
ID: 38295461
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")
0
 

Author Comment

by:AndreasHermle
ID: 38295599
Thank you very much for your superb support. I will test it this evening and let you know.

Thank you very much. Regards, Andreas
0
 

Author Comment

by:AndreasHermle
ID: 38299496
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
0
 
LVL 19

Expert Comment

by:Arno Koster
ID: 38299937
andreas, which errors do you perceive in the results of the second code ?
0
 
LVL 13

Expert Comment

by:Ryan
ID: 38300632
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.
0
 

Author Comment

by:AndreasHermle
ID: 38311497
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
0

Featured Post

VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Access developers frequently have requirements to interact with Excel (import from or output to) in their applications.  You might be able to accomplish this with the TransferSpreadsheet and OutputTo methods, but in this series of articles I will di…
This article describes how you can use Custom Document Properties to store settings and other information in your workbook so that they will be available the next time you open the workbook.
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.

830 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question