A
amorrison2006
I need the above to insert rows after cells D24 for the above of rows
it would require in order to paste the figures in.....
Copy from the data sheet to the summary sheet all the bold cells in
column C and then then offset to the left and copy the header for that
bold cell.
Copy both cells to the summary sheet by inserting rows in the summary
sheet after cell D24.
I hope this makes sense and someone could help me,
This is the macro I have so far......
Public Sub CopyRange()
Dim WB As Workbook
Dim srcSH As Worksheet
Dim destSH As Worksheet
Dim srcRng As Range
Dim rCell As Range
Dim copyRng As Range
Dim destRng As Range
Dim LRow As Long
Dim CalcMode As Long
Set WB = Workbooks("MyBook.xls") '<<=== CHANGE
With WB
Set srcSH = .Sheets("Sheet1") '<<=== CHANGE
Set destSH = .Sheets("Sheet2") '<<=== CHANGE
End With
Set srcRng = srcSH.Range("A1:A20") '<<==== CHANGE
With destSH
LRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set destRng = .Range("A" & LRow + 1)
End With
On Error GoTo XIT
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
For Each rCell In srcRng.Cells
If rCell.Font.Bold = True Then
If copyRng Is Nothing Then
Set copyRng = rCell
Else
Set copyRng = _
Union(rCell, copyRng)
End If
End If
Next rCell
If Not copyRng Is Nothing Then
copyRng.EntireRow.Copy Destination:=destRng
End If
XIT:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
End Sub
Thanks
Andrea
it would require in order to paste the figures in.....
Copy from the data sheet to the summary sheet all the bold cells in
column C and then then offset to the left and copy the header for that
bold cell.
Copy both cells to the summary sheet by inserting rows in the summary
sheet after cell D24.
I hope this makes sense and someone could help me,
This is the macro I have so far......
Public Sub CopyRange()
Dim WB As Workbook
Dim srcSH As Worksheet
Dim destSH As Worksheet
Dim srcRng As Range
Dim rCell As Range
Dim copyRng As Range
Dim destRng As Range
Dim LRow As Long
Dim CalcMode As Long
Set WB = Workbooks("MyBook.xls") '<<=== CHANGE
With WB
Set srcSH = .Sheets("Sheet1") '<<=== CHANGE
Set destSH = .Sheets("Sheet2") '<<=== CHANGE
End With
Set srcRng = srcSH.Range("A1:A20") '<<==== CHANGE
With destSH
LRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set destRng = .Range("A" & LRow + 1)
End With
On Error GoTo XIT
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
For Each rCell In srcRng.Cells
If rCell.Font.Bold = True Then
If copyRng Is Nothing Then
Set copyRng = rCell
Else
Set copyRng = _
Union(rCell, copyRng)
End If
End If
Next rCell
If Not copyRng Is Nothing Then
copyRng.EntireRow.Copy Destination:=destRng
End If
XIT:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
End Sub
Thanks
Andrea