Re asking help

[Beekman]

Dim ws1 As Worksheet<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
Dim ws2 As Worksheet<o></o>
Dim ws3 As Worksheet<o></o>
Dim ws4 As Worksheet<o></o>
Dim ws5 As Worksheet<o></o>
Dim ws6 As Worksheet<o></o>
Dim iLastRow As Long<o></o>
Dim iRow As Long<o></o>
Dim iOutRow As Long<o></o>
<o></o>
Set ws1 = ThisWorkbook.Sheets("HEADER")<o></o>
Set ws2 = ThisWorkbook.Sheets("MONDAY")<o></o>
Set ws3 = ThisWorkbook.Sheets("TUESDAY")<o></o>
Set ws4 = ThisWorkbook.Sheets("WEDNESDAY")<o></o>
Set ws5 = ThisWorkbook.Sheets("THURSDAY")<o></o>
Set ws6 = ThisWorkbook.Sheets("FRIDAY")<o></o>
<o></o>
iLastRow = ws1.Range("B5").End(xlDown).Row<o></o>
<o></o>
iOutRow = 10<o></o>
For iRow = 5 To iLastRow<o></o>
iOutRow = iOutRow + 1<o></o>
ws1.Cells(iRow, "B").Copy Destination:=ws2.Cells(iOutRow, "A")<o></o>
If ws1.Cells(iRow, "B").Value >= 4100 And ws1.Cells(iRow, "B").Value <= 4130 Then<o></o>
iOutRow = iOutRow + 1<o></o>
ws1.Cells(iRow, "B").Copy Destination:=ws2.Cells(iOutRow, "A")<o></o>
End If<o></o>
Next iRow<o></o>
iOutRow = 10<o></o>
For iRow = 5 To iLastRow<o></o>
iOutRow = iOutRow + 1<o></o>
ws1.Cells(iRow, "B").Copy Destination:=ws2.Cells(iOutRow, "A")<o></o>
If ws1.Cells(iRow, "B").Value >= 4100 And ws1.Cells(iRow, "B").Value <= 4130 Then<o></o>
iOutRow = iOutRow + 1<o></o>
ws1.Cells(iRow, "B").Copy Destination:=ws2.Cells(iOutRow, "A")<o></o>
End If<o></o>
Next iRow<o></o>
This macrow works for me in duplicating 4100-4300 eg

4100
4100
4101
4101
etc
but some of the numbers end in a letter eg

4110W
4117M
etc
the macro does'nt see this as a number between 4100-4300 and won't duplicate them.
Can anyone come up with a modification of above macro so it will duplicate both number and number with letter ending.

Thanks for any help

 

[Trebor76]

Hi Beekman,

Obviously largely untested, but see how this goes:

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim ws4 As Worksheet
Dim ws5 As Worksheet
Dim ws6 As Worksheet
Dim iLastRow As Long
Dim iRow As Long
Dim iOutRow As Long

Set ws1 = ThisWorkbook.Sheets("HEADER")
Set ws2 = ThisWorkbook.Sheets("MONDAY")
Set ws3 = ThisWorkbook.Sheets("TUESDAY")
Set ws4 = ThisWorkbook.Sheets("WEDNESDAY")
Set ws5 = ThisWorkbook.Sheets("THURSDAY")
Set ws6 = ThisWorkbook.Sheets("FRIDAY")

iLastRow = ws1.Range("B5").End(xlDown).Row

iOutRow = 10
For iRow = 5 To iLastRow
iOutRow = iOutRow + 1
ws1.Cells(iRow, "B").Copy Destination:=ws2.Cells(iOutRow, "A")
If ws1.Val(Left(Cells(iRow, "B"), 4)) >= 4100 And ws1.Val(Left(Cells(iRow, "B"), 4)) <= 4130 Then
iOutRow = iOutRow + 1
ws1.Cells(iRow, "B").Copy Destination:=ws2.Cells(iOutRow, "A")
End If
Next iRow
iOutRow = 10
For iRow = 5 To iLastRow
iOutRow = iOutRow + 1
ws1.Cells(iRow, "B").Copy Destination:=ws2.Cells(iOutRow, "A")
If ws1.Val(Left(Cells(iRow, "B"), 4)) >= 4100 And ws1.Val(Left(Cells(iRow, "B"), 4)) <= 4130 Then
iOutRow = iOutRow + 1
ws1.Cells(iRow, "B").Copy Destination:=ws2.Cells(iOutRow, "A")
End If
Next iRow

HTH

Robert

 

[Beekman]

If ws1.Val(Left(Cells(iRow, "B"), 4

Code stops running at .Val Robert

 

[Trebor76]

Try this line of code...

If Val(Left(ws1.Cells(10, "A"), 4)) >= 4100 And Val(Left(ws1.Cells(10, "A"), 4)) <= 4130 Then

...in the relevant two lines of your procedure.

 

[Beekman]

Sorry, Robert, macro ran o.k. now but still not duplicating numbers ending in a letter

 

[Trebor76]

Not sure I'm afraid. Hopefully someone on the forum will have a solution.