VBA Copy, Paste and Format

**Vlad999** · 04-19-2006, 01:46 AM

Okay I have been trying to set up this macro to copy and paste rows where a tick box is checked. The macro needs to transfer the row A:H over to sheet 2 then insent the data acording to property title either A, B, C etc. into formated tables which then feed into a bar and pie chart. I have tried posting this question up in sections hoping that i could get the bits of code i need and then work out how to do the macro but I have had no luck since my VBA skills are poor. I have attached the file I am working on and have provided an explaination of what i want to happen hopefully someone can work out what I want and provide me with a solution. Below are some sections of code that some very helpful people have provided me with they may assist you in helping me out or if you have a similar problem it may be useful.

NOTE: There may be up to 20 tables with 40 rows per table at times

Provided by Alan
VBA:

Private Sub CommandButton1_Click() 
    Dim lRow As Long, lRow1 As Long, lRow2 As Long 
    Dim Target As Range 
    Dim vTemp As Variant 
    Dim WS2 As Worksheet 
     
    Set WS2 = Sheets("Sheet2") 
     
    lRow = WS2.UsedRange.Row + WS2.UsedRange.Rows.Count 
    For Each Target In Range("I1", Cells(Rows.Count, "I").End(xlUp).Address).SpecialCells(xlCellTypeConstants) 
        vTemp = Target.Value 
        If VarType(vTemp) = vbBoolean Then 
             
            If vTemp = True Then 
                 
                vTemp = "*" 
                On Error Resume Next 
                vTemp = WorksheetFunction.Match("Total*", Range("A" & Target.Row, "A" & Rows.Count), 0) 
                On Error Goto 0 
                If IsNumeric(vTemp) Then 
                    lRow1 = Target.Row + 1 
                    lRow2 = lRow + vTemp - 2 
                    With WS2 
                        .Range("B" & lRow, "I" & lRow + vTemp - 1).Value _ 
                        = Range("A" & lRow1, "H" & lRow1 + vTemp - 1).Value 
                        .Range("A" & lRow, "A" & lRow2).Value = Cells(Target.Row, "A").Value 
                        lRow = lRow + vTemp - 1 
                    End With 
                End If 
            End If 
        End If 
    Next Target 
End Sub

Provided by Tom
VBA:

Sub ABC() 
    Dim rng As Range, ar As Range 
    Dim rng1 As Range, rng2 As Range 
    Dim cell As Range, c As Range 
    Set rng = Worksheets("Sheet1") _ 
    .Range("H1:H1000").SpecialCells(xlBlanks) 
    For Each ar In rng.Areas 
        ar.EntireRow.Copy Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp)(4) 
    Next 
    With Worksheets("Sheet2") 
        If IsEmpty(.Cells(1, 1)) And IsEmpty(.Cells(2, 1)) Then 
            Set c = .Cells(1, 1).End(xlDown) 
            .Range(.Cells(1, 1), c.Offset(-2, 0)).EntireRow.Delete 
        End If 
        Set rng1 = .Range(.Range("A2"), .Cells(Rows.Count, 1).End(xlUp)) 
         
        For Each cell In rng1 
            If InStr(1, cell, "total", vbTextCompare) Then 
                If rng2 Is Nothing Then 
                    Set rng2 = cell 
                Else 
                    Set rng2 = Union(rng2, cell) 
                End If 
            End If 
        Next 
        If Not rng2 Is Nothing Then 
            rng2.EntireRow.Copy rng1(rng1.Count).Offset(3, 0) 
            rng2.EntireRow.Delete 
        End If 
    End With 
     
End Sub

URL TO SPREADSHEET

http://www.ozgrid.com/forum/attachme...7&d=1145420092