Adding Formatting to Code

D

DaveH

I seem to be having brain lock and cannot figure out how to add additional
formatting to my code.
Code below.
I'm looking for cells that contain markers and copying that range to a new
worksheet. I'm retaining the value of the cells and also would like to format
the cells with the ">" marker as bold and LeftJustified.
Your suggestions would be greatly appreciated.

Dave

Sheets("Items").Activate
ktr = 8
Set percrange = Range(Cells(1, 1), Cells(150, 1))
For Each thing In percrange
If IsNumeric(thing) And (thing > 0) Or (thing = ">") Or (thing =
">>") Then
ktr = ktr + 1
currrow = thing.Row
Range(Cells(currrow, 1), Cells(currrow, 9)).Select
Range(Cells(currrow, 1), Cells(currrow, 9)).Copy
Sheets("Sheet").Activate
Range(Cells(ktr, 1), Cells(ktr, 9)).PasteSpecial (xlPasteValues)
Sheets("Items").Activate
End If
Next
 
D

Don Guillett

This could be a lot more efficient. Show us your layout or send your wb to
my address below with before/after examples.
 
D

Don Guillett

Sub OrderSheetSAS()
Dim lr, br, dlr As Long
Dim c, firstaddress, i
Sheets("Order Sheet").Rows("7:100").Delete
With Worksheets("Fortis Items")
lr = .Cells(Rows.Count, "a").End(xlUp).Row
On Error Resume Next
For Each c In .Range("a2:a" & lr)
If InStr(c, ">") Or c > 0 Then
dlr = Sheets("Order Sheet").Cells(Rows.Count, 1).End(xlUp).Row + 1
Sheets("Order Sheet").Range("c1:c4").Value = _
Sheets("System Configurator").Range("c3:e6").Value
Sheets("Order Sheet").Rows(dlr).Value = .Rows(c.Row).Value
End If
Next c
End With
CleanUpSAS
End Sub

Sub CleanUpSAS()
Dim lr As Long
Dim c
With Sheets("Order Sheet")
lr = .Cells(Rows.Count, 1).End(xlUp).Row
For Each c In .Range("a7:a" & lr)
If InStr(c, ">") Then
..Rows(c.Row).Font.Bold = True
c.ClearContents
End If
Next c
End With
End Sub
 
D

DaveH

Don,
Works like a charm!
Many many thanks!

Don Guillett said:
Sub OrderSheetSAS()
Dim lr, br, dlr As Long
Dim c, firstaddress, i
Sheets("Order Sheet").Rows("7:100").Delete
With Worksheets("Fortis Items")
lr = .Cells(Rows.Count, "a").End(xlUp).Row
On Error Resume Next
For Each c In .Range("a2:a" & lr)
If InStr(c, ">") Or c > 0 Then
dlr = Sheets("Order Sheet").Cells(Rows.Count, 1).End(xlUp).Row + 1
Sheets("Order Sheet").Range("c1:c4").Value = _
Sheets("System Configurator").Range("c3:e6").Value
Sheets("Order Sheet").Rows(dlr).Value = .Rows(c.Row).Value
End If
Next c
End With
CleanUpSAS
End Sub

Sub CleanUpSAS()
Dim lr As Long
Dim c
With Sheets("Order Sheet")
lr = .Cells(Rows.Count, 1).End(xlUp).Row
For Each c In .Range("a7:a" & lr)
If InStr(c, ">") Then
..Rows(c.Row).Font.Bold = True
c.ClearContents
End If
Next c
End With
End Sub

--
Don Guillett
Microsoft MVP Excel
SalesAid Software
[email protected]
Click to expand...
 
Top