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
Bookmarks