VB Macro - Cppy rows of one sheet into mutiple sheets based on column value

[wester69]

I found this macro and modified it a bit. It does a great job copin
rows from a "main" sheet into multiple sheets based off a column value
I am struggling now to go to a deeper level were it will copy the ro
based on one column value looking at all sheets in a workbook. S
instead of it looking a at column value, creating a sheet if that valu
does not exist then copying the mathing column data to that sheet.
want to compare and look at the same column of all sheets in m
workbook (column B in my case) and copy the row of matching data fro
my "main" sheet (column B).

So I want all my rows that have "excel.exe" in my "main" sheet to go t
my "MS Excel" named sheet and all my "winprog.exe" rows to go my "M
Project" named sheet and etc.

Any assistance would be appreciated!

Thanks

Wesley



Sub CopyRowsToSheets()

'copy rows to worksheets based on value in column A

'assume the worksheet name to paste to is the value in Col A

Dim CurrentCell As Range
Dim SourceRow As Range
Dim Targetsht As Worksheet
Dim TargetRow As Long
Dim CurrentCellValue As String

'start with cell A2 on "Master" sheet
Set CurrentCell = Worksheets("Master").Cells(2, 1) 'row ... column ...

Do While Not IsEmpty(CurrentCell)
CurrentCellValue = CurrentCell.Value
Set SourceRow = CurrentCell.EntireRow

'Check if worksheet exists
On Error Resume Next

Testwksht = Worksheets(CurrentCellValue).Name

If Err.Number = 0 Then

'MsgBox CurrentCellValue & " worksheet Exists"
Else

MsgBox "Adding a new worksheet for " & CurrentCellValue

Worksheets.Add.Name = CurrentCellValue

End If

On Error GoTo 0 'reset on error to trap errors again

Set Targetsht = ActiveWorkbook.Worksheets(CurrentCellValue)

' Find next blank row in Targetsht - check using Column A
TargetRow = Targetsht.Cells(Rows.Count, 1).End(xlUp).Row + 1
SourceRow.Copy Destination:=Targetsht.Cells(TargetRow, 1)

'do the next cell
Set CurrentCell = CurrentCell.Offset(1, 0)

Loop

End Su

 

[wester69]

I figured out my mistake, "UCase" was killing me. Here is the workin
macro.

-Wesley


Sub Mark_zOpen()

Dim lastrow As Long, r As Long
lastrow = ActiveSheet.UsedRange.Rows.Count

For r = lastrow To 1 Step -1

'Look for empty cell and put "zOpen" in empty cell
If Cells(r, 1).Value = "" Then Cells(r, 1).Value = "zOpen"

'Look for zOpen value and mark it blue
If Cells(r, 1).Value = "zOpen" Then Cells(r, 1).Font.Color = RGB(0
0, 255)

Next r

MsgBox "Empty & 'Open' slots have been marked."

End Su