Solved: Moving Rows with repeated value to different Tab

[AdrianK]

Hello All,

I'm currently working on a macro to format some information from an invoicing system, moving the details to different sheets depending on payment status, which is fine.

I am having a mental block with the next section of my project, where I need to move all rows, where there are multiple invoices for a purchase order number, to a seperate sheet.

The purchase order number is in column A, and for each one where there is > 1 row with this number I need to move all rows with that value in column A to a the new sheet.

I was thinking maybe advanced filtering (for unique records), copying to an array and then counting, but to be honest I am not really sure where to start.

Purchase order numbers contain numbers and letters so would need to be stored as a string.

Any help would be most appreciated.

I have included what I have so far below.

Many thanks,

Adrian

[vba]
Sub FINANCE_Format()

Dim intFINALROW As Integer
Dim arrFILTERS(1 To 5) As String
Dim intARRAY As Integer

arrFILTERS(1) = "Invoice Paid"
arrFILTERS(2) = "Ready for Payment"
arrFILTERS(3) = "On FINANCE - Not on Remittance"
arrFILTERS(4) = "Registered but not Ready"
arrFILTERS(5) = "POs with Multiple Invs"

intFINALROW = ActiveSheet.UsedRange.Rows.Count

Sheets(1).Name = "FINANCE"

' Add autofilter if it's not there
If ActiveSheet.AutoFilterMode = False Then

Rows(1).AutoFilter

End If

' Format sheet/header
Range("A2").Select
ActiveWindow.freezepanes = True
Cells.EntireColumn.AutoFit

Range("A1:U1").Font.Bold = True

Range("U:U").Select

' Replace incorrect terminology
Selection.Replace What:="Processed through FINANCE, but not on Remittance Advice - Cancelled??", _
Replacement:="On FINANCE - Not on Remittance", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Selection.Replace What:="Registered, but not ready for payment", _
Replacement:="Registered but not Ready", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

' Loop through first 4 array elements creating the tabs
For intARRAY = 1 To 4

Selection.AutoFilter field:=21, Criteria1:=arrFILTERS(intARRAY)

Sheets.Add.Name = arrFILTERS(intARRAY)
Sheets(arrFILTERS(intARRAY)).Move Before:=Sheets("FINANCE")

Sheets("FINANCE").Range("A1:U" & intFINALROW + 3).SpecialCells(xlCellTypeVisible).Copy _
Destination:=Sheets(arrFILTERS(intARRAY)).Range("A1")

Cells.EntireColumn.AutoFit

Sheets("FINANCE").Select

Next intARRAY

Sheets("FINANCE").Select ' Select sheet
Selection.AutoFilter field:=21 ' Remove filter

' Create tab for lines where there is more than one invoice per PO number
Sheets.Add.Name = arrFILTERS(5)



End Sub
[/vba]

[MaximS]

try something like that:

[VBA]
Sub Macro1()
Dim Wb As Workbook
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim Rng As Range
Dim Lr As Long, i As Long, y As Long
Set Wb = ThisWorkbook
Set Sh1 = Wb.Sheets("Sheet1")
Set Sh2 = Wb.Sheets("Sheet2")
Lr = Sh1.Range("A" & Rows.Count).End(xlUp).Row
Set Rng = Sh1.Range("A1:A" & Lr)

Sh1.Range("A1:X" & Lr).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

For i = Lr To 2 Step -1
x = WorksheetFunction.CountIf(Rng, Cells(i, 1).Value)

If x > 1 Then
y = Sh2.Range("A" & Rows.Count).End(xlUp).Row
Sh2.Range("A" & y & ":X" & y + x - 1).Value = _
Sh1.Range("A" & i & ":X" & i - x + 1).Value
Sh1.Range("A" & i & ":X" & i - x + 1).Delete

End If
Next i


End Sub
[/VBA]

[AdrianK]

Thanks MaximS

I tried your code, but although it seemed to split out the lines with multiple entries, it also split out some of the other lines too.

It did give me some ideas, and I fixed the problem with the below code.

Cheers,

Adrian

[vba]
Sub FINANCE_Format()

Dim intFINALROW As Integer
Dim intUNFINAL As Integer
Dim intNO As Integer
Dim strSHTNAME As String
Dim arrFILTERS(1 To 7) As String
Dim intARRAY As Integer
Dim strVALUE As String
Dim intCOUNT As Integer

arrFILTERS(1) = "Invoice Paid"
arrFILTERS(2) = "Ready for Payment"
arrFILTERS(3) = "On FINANCE - Not on Remittance"
arrFILTERS(4) = "Registered but not Ready"
arrFILTERS(5) = "Invoice Line Status"
arrFILTERS(6) = "Sub Total by PO No"
arrFILTERS(7) = "POs with Multiple Invs"

intFINALROW = ActiveSheet.UsedRange.Rows.Count

Sheets(1).Name = "FINANCE"

If ActiveSheet.AutoFilterMode = False Then
Rows(1).AutoFilter
End If
Range("A2").Select
ActiveWindow.freezepanes = True
Cells.Select
Selection.EntireColumn.AutoFit
Selection.VerticalAlignment = xlCenter

Range("A1:U1").Select
Selection.Font.Bold = True

Range("U:U").Select

Selection.Replace What:="Processed through FINANCE, but not on Remittance Advice - Cancelled??", _
Replacement:="On FINANCE - Not on Remittance", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Selection.Replace What:="Invoice Registered, but not ready for payment", _
Replacement:="Registered but not ready", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

For intARRAY = 1 To 4

Selection.AutoFilter field:=21, Criteria1:=arrFILTERS(intARRAY)

Sheets.Add.Name = arrFILTERS(intARRAY)
Sheets(arrFILTERS(intARRAY)).Move Before:=Sheets("FINANCE")

Sheets("FINANCE").Range("A1:U" & intFINALROW + 3).SpecialCells(xlCellTypeVisible).Copy _
Destination:=Sheets(arrFILTERS(intARRAY)).Range("A1")

Cells.EntireColumn.AutoFit

Sheets("FINANCE").Select

Next intARRAY

Sheets("FINANCE").Select
Selection.AutoFilter field:=21

Sheets.Add.Name = arrFILTERS(6)

Sheets("FINANCE").Rows("1:1").Copy Destination:=Sheets(arrFILTERS(6)).Rows("1:1")

Sheets.Add.Name = arrFILTERS(7)

Sheets("FINANCE").Rows("1:1").Copy Destination:=Sheets(arrFILTERS(7)).Rows("1:1")

Sheets.Add.Name = "UNIQUE"

Sheets("FINANCE").Select

Columns("O:O").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns( _
"W:W"), Unique:=True

Columns("W:W").Select
Selection.Cut
Sheets("UNIQUE").Select
Columns("A:A").Select
ActiveSheet.Paste
Columns("A:A").EntireColumn.AutoFit
Range("A1").Select

Sheets("FINANCE").Select
Rows(1).Select
Selection.AutoFilter

Sheets("UNIQUE").Select

intUNFINAL = Range("A65536").End(xlUp).Row

For intNO = 2 To intUNFINAL

strVALUE = Range("A" & intNO).Value

Sheets("FINANCE").Select

Selection.AutoFilter field:=15, Criteria1:=strVALUE

intCOUNT = WorksheetFunction.CountA(Range("O:O").SpecialCells(xlCellTypeVisible))

If intCOUNT > 2 Then

Range("2:" & intFINALROW + 2).SpecialCells(xlCellTypeVisible).Copy _
Destination:=Sheets(arrFILTERS(7)).Range("A" & _
Sheets(arrFILTERS(7)).Range("O65536").End(xlUp).Row + 1)

Else

Range("2:" & intFINALROW + 2).SpecialCells(xlCellTypeVisible).Copy _
Destination:=Sheets(arrFILTERS(6)).Range("A" & _
Sheets(arrFILTERS(6)).Range("O65536").End(xlUp).Row + 1)

End If

Sheets("UNIQUE").Select

Next intNO

Sheets("UNIQUE").delete

End Sub
[/vba]

[mdmackillop]

Hi Adrian,
Using Find, have a lookat posts 10 & 11 here