Hello AK :
I'm thinking your problems start with your codes lines ..
On Error Resume Next
Set ws = Sheets("search")You cannot set WS to the sheet named "search" because the sheet is "Search" (i.e. upper case "S").
But your "On Error" allows you to proceed even though no sheet has been set to "WS".
Cheers.
No problem, Justin did all the heavy lifting ... cheers
Hello PVMan;
Justins work is great ! But here is some code that might clear up the new requirements (e.g. cells with no values and leading zeros) ... if you'd like.
If you want to continue and wait for Justin to get back to you , that's cool too.
cheers
Sub EditNumberStrig()
Dim NumList, NumStr
Dim Num As String, editedNumStr As String
For Each NumList In Columns("A:A").SpecialCells(xlCellTypeConstants, 3)
editedNumStr = ""
For Each NumStr In Split(NumList, ",")
Num = Trim(NumStr)
If Left(Num, 2) = "05" Or Left(Num, 1) = "5" Then
If editedNumStr = "" Then
editedNumStr = Num
Else
editedNumStr = editedNumStr & "," & Num
End If
End If
Next NumStr
NumList.NumberFormat = "@"
NumList.Value = editedNumStr
Next NumList
End SubHello RoyUK 
I tried the code you provided above but not sure if I'm doing something wrong. Fred has requested the cutting of all odd number cells in Column C ... but when I use your code it cuts all the cells . i.e. including C2, C4 which Fred had indicated he did not want cut. ... I'm I missing something ?
Cheers
Nimrod11313
Public Sub MultiCut()
Dim i
For i = 1 To 3000 Step 2
Range("C" & i).Cut Destination:=Range("A" & i + 1)
Next i
End SubThis solution requires the work orders to be sorted into order prior to the running of code.
Option Explicit
Enum Columns
WoSrc = 1
EquipSrc = 2
WoTarg = 5
EquipTarg = 6
End Enum
Public Sub TransposeData()
Dim Wo
Dim equipList As New Collection
Dim key As Long
Dim targCol As Integer, targRow As Integer
targRow = 2
For Each Wo In Cells(1, Columns.WoSrc).EntireColumn.SpecialCells(xlCellTypeConstants, 1)
equipList.Add Cells(Wo.Row, Columns.EquipSrc).Value
If Not Wo.Value = Cells(Wo.Row + 1, Columns.WoSrc).Value Then
targCol = Columns.EquipTarg
For key = 1 To equipList.Count
Cells(targRow, Columns.WoTarg).Value = Wo.Value
Cells(targRow, targCol).Value = equipList(key)
targCol = targCol + 1
Next key
targRow = targRow + 1
Set equipList = New Collection
End If
Next Wo
End SubOption Compare Text
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Column = 2 And Target.Cells.Count = 1 Then
If Target.Value = "male" Or Target.Value = "female" Then
With Sheets(WorksheetFunction.Proper(Target.Value) & "s")
Target.EntireRow.Copy .Range("B" & .Rows.Count).End(xlUp).Offset(1, 0).EntireRow
Target.EntireRow.Delete
End With
End If
End If
End SubHello:
When I watch the video I do notice one odd thing. The project window shows that you've created a module BUT the "Sheet1" is what is highlighted. So the code you're looking at is in Sheet1 and not the module. Check to see what has been produced in the code window in both places. Clear both the code from sheet1 and module1 and try recording again. I wondering if the ".Header. = 12" is a line in the Sheet1 code window that's causing the problem.
I used the workbook function Advanced Filter and Countifs to come up with this Soln ... maybe you will find it interesting.
Sub RollUpStats()
Dim user
'Copy original Sheet
ActiveSheet.Copy After:=ActiveSheet
'Create unique listings from original data
Columns("A:C").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("E1"), Unique:=True
'Tally/Count using original listing
For Each user In Columns("E:E").SpecialCells(xlCellTypeConstants, 3)
user.Offset(0, -1) = Application.WorksheetFunction. _
CountIfs(Range("A:A"), Range("E" & user.Row), Range("B:B"), Range("F" & user.Row), Range("C:C"), Range("G" & user.Row))
Next user
'Delete copy of orig listings
Columns("A:C").Delete Shift:=xlToLeft
Range("A1").Value = "Tally"
End SubSub Copy_sheet_1_to_another()
Call copyRange("B17:E22,I17:L22,A24:F24,B47:L49,U20:Z20,U22:Z33", "Proposal 1", "Proposal 2")
End Sub
Public Sub copyRange(ranges As String, sourceSheet, targetSheet)
Dim rngAddr
For Each rngAddr In Split(ranges, ",")
Sheets(sourceSheet).Range(rngAddr).Copy Destination:=Sheets(targetSheet).Range(rngAddr)
Next rngAddr
End Sub