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
(E-Mail Removed)
"DaveH" <(E-Mail Removed)> wrote in message
news:718D7C63-7F3A-49CA-92C2-(E-Mail Removed)...
> I'll send you my wb.
>
> "Don Guillett" wrote:
>
>> This could be a lot more efficient. Show us your layout or send your wb
>> to
>> my address below with before/after examples.
>>
>> --
>> Don Guillett
>> Microsoft MVP Excel
>> SalesAid Software
>> (E-Mail Removed)
>> "DaveH" <(E-Mail Removed)> wrote in message
>> news:C439EC79-8766-4BF2-8B1A-(E-Mail Removed)...
>> >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
>> >
>>
>>
Similar Threads
