copy cells in two columns if in bold to another sheet and insert rows

[amorrison2006]

Hello

I'd appreciate any help someone could give with this issue,

I've not been very lucky with responses lately on this newsgroup.

I need a macro to copy cells in a column which are in bold and if they
are in bold then copy the cell next to this and the one in bold to
another sheet from Cell E26 by inserting a row in order to copy them
and shift rows down.

I am hoping someone could look at this for me as its the last part of
what I need to do and then there'd be no more questions on the same
thing,

Thanks in advance,

Andrea

 

[Guest]

Andrea,

Well if this works then your lick just changed. Checks column A for boold
cell and if it finds on copies that cell and the one next to it to E26

Sub mariner()
Dim myRange As Range
Set myRange = Range("A1:a100") '<=========Alter to suit
For Each c In myRange
c.Select
x = c.Address
If Selection.Font.Bold = True Then
numRows = Selection.Rows.Count
numColumns = Selection.Columns.Count
Selection.Resize(numRows + 0, numColumns + 1).Select
Selection.Copy
Worksheets("Sheet2").Cells(26, 5).Insert shift:=xlDown
End If
Next
End Sub

Will that do?

Mike

 

[amorrison2006]

Hello Mike

Thanks for your response,

I greatly appreciate this,

I've been ignored for days on this newsgroup.....

The words to a certain degree. I want to shift the rows down in the
sheet it copies to as I have data below which is required to be
completed by the user. Shifting cells down puts everything out of
place,

Hope you can help with this adjustment,

Thanks so much

Andrea

 

[Guest]

And if Mike's don't work the way you want, you can try this one:

Sub cpybls()
For Each cell In Worksheets(1).Range("$A$1:$E$15")
If cell.Font.Bold = True Then
If Not cell Is Nothing Then
fRng = cell.Address
End If
pRng = Range(fRng).Offset(0, 1).Address
Worksheets(2).Range("$E$26").EntireRow.Insert
Range(fRng & ":" & pRng).Copy
Worksheets(2).Range("$E$26").PasteSpecial Paste:=xlValues
End If
Application.CutCopyMode = False
Next
End Sub

Since Mike and I had to do a lot of guessing about the sheets your data is
on, and what range the data is in (out of over 16 million possibilities), we
could have guessed wrong. In that case, just post again and give a little
bit more information like: My data is located in range A1:H250 on Sheet 2
and I want to find all the cells with bold font and move each cell with the
bold font along with the cell to its (left/right/above/below - pick one) to
sheet 3 starting at cell X20 and continuing in column X downward by inserting
new rows.

I know that it is not easy to ask for help when you don't understand how
something works. That is why I tried to show you how to help us help you.

 

[Guest]

I still may not understand but here we go version 2.

1. Loop now executes backwards to keep data in same order.
2. An entire row is inserted at row 26 shifting everything down.

Sub versive()
Dim myRange As Range
For x = 100 To 1 Step -1
Cells(x, 1).Select ' The 1 represents column A alter to suit
If Selection.Font.Bold = True Then
Selection.Resize(1 + 0, 1 + 1).Select
Worksheets("Sheet2").Range("$E$26").EntireRow.Insert
Selection.Copy
Sheets("Sheet2").Range("G26").PasteSpecial Paste:=xlPasteValues
End If
Next
End Sub

Mike