V
Vlad999
Okay I have been trying to set up this macro to copy and paste row
where a tick box is checked. The macro needs to transfer the row A:
over to sheet 2 then insent the data acording to property title eithe
A, B, C etc. into formated tables which then feed into a bar and pi
chart. I have tried posting this question up in sections hoping that
could get the bits of code i need and then work out how to do the macr
but I have had no luck since my VBA skills are poor. I have attached th
file I am working on and have provided an explaination of what i want t
happen hopefully someone can work out what I want and provide me with
solution. Below are some sections of code that some very helpful peopl
have provided me with they may assist you in helping me out or if yo
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:
Code
-------------------
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:
Code
-------------------
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/attachment.php?attachmentid=13837&d=114542009
where a tick box is checked. The macro needs to transfer the row A:
over to sheet 2 then insent the data acording to property title eithe
A, B, C etc. into formated tables which then feed into a bar and pi
chart. I have tried posting this question up in sections hoping that
could get the bits of code i need and then work out how to do the macr
but I have had no luck since my VBA skills are poor. I have attached th
file I am working on and have provided an explaination of what i want t
happen hopefully someone can work out what I want and provide me with
solution. Below are some sections of code that some very helpful peopl
have provided me with they may assist you in helping me out or if yo
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:
Code
-------------------
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:
Code
-------------------
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/attachment.php?attachmentid=13837&d=114542009