• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

copy all rows that have the same cel to another sheet

S

SanDiegoCasey

New Member
I've got a daily report of sales with a constant number of columns , but depending on orders and items it could have many rows. .Every item gets a row.

I would like to transfer every order that has multiple items in it to another sheet. so that the first sheet is just single item order?

My current spreadsheet looks like this

Order,REF#,AISLE,RW,BIN,SKU,Size,Qty,Ship,pick#,Customer
367,4276,15,4,1,J8143,sz:4,1,1stClass,34,12
367,4276,10,2,3,J8956,sz:6,1,1stClass,34,12
368,4278,11,1,2,J6061,sz:9,1,1stClass,35,13
368,4278,23,7,102,J6142,sz:9,1,1stClass,35,13
369,4351,10,1,1,J8833,sz:12,1,1stClass,36,15


I'm trying to come up with a macro that will look for any rows that have the same order number, then move all of those to sheet two.

I found a code that moves them but leaves the first row? I need all rows that belong to that order to go to sheet two?

If there is an existing example somewhere you could point me to that would be fine.

THANKS!
 
Hi ,

Can you clarify how many sheets will be present in the workbook , both before and after the macro is run ?

Will the first sheet consist of all single-item orders , while a second sheet will consist of all multiple-item orders ?

Or will each order get its own tab ?

Narayan
 
NARAYANK991 said:
Hi ,

Can you clarify how many sheets will be present in the workbook , both before and after the macro is run ?

Will the first sheet consist of all single-item orders , while a second sheet will consist of all multiple-item orders ?

Or will each order get its own tab ?

Narayan
Click to expand...

That is correct, two sheets only, first will be all single item orders, second will be all multi item orders...

Well, actually... that's another step but in the end i would be making the multi item orders sheet into two, all the same data, just one would be sorted by order number, and the other would be sorted by location in the warehouse so when I walk through the backroom to grab stuff i can grab it in sequence. But I figured I wouldn't complicate this for now. LOL
 
didn't realize you could upload stuff here, Here is a sample file to look at. Also, again, this wasn't part of my question, but... if there is anyway that when the multi order rows are transferred to sheet two that they could have a space in between them? That would be perfect!
 

Attachments

Hi ,

The sort by Aisle , Row and Bin can certainly be done in code , but can you confirm the following ?

Once the data is sorted in the above order , the order numbers themselves will be dispersed ; do you want any blank row separation in between orders , or do you want the blank row separation in between the warehouse locations , so that there is a blank row when ever the Bin changes , or the Row changes or the Aisle changes or any combination of these changes ?

Narayan
 
NARAYANK991 said:
Hi ,

The sort by Aisle , Row and Bin can certainly be done in code , but can you confirm the following ?

Once the data is sorted in the above order , the order numbers themselves will be dispersed ; do you want any blank row separation in between orders , or do you want the blank row separation in between the warehouse locations , so that there is a blank row when ever the Bin changes , or the Row changes or the Aisle changes or any combination of these changes ?

Narayan
Click to expand...
the ones that are sorted by location can all be right together, there doens't need to be any visual separation. The page with the items grouped by order would need some kind of distinction. I was going to try and do it with some conditional formatting, but I'm so new at Excel, I don't know if there is a better way? Adding a row, adding some sort of spacer? Not sure?


I posted an example file. The first sheet is the data the way it starts, then it has "sheet2" currently empty, then I have 3 more sheets that are samples of what the actual final 3 sheets should be.

Hope that helps?
 
Try
Code: 
Sub test()
    Dim a, i As Long, temp As Long, x As Range, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    With Sheets("sheet1").Cells(1).CurrentRegion
        a = .Columns(1).Value
        For i = 2 To UBound(a, 1)
            If Not dic.exists(a(i, 1)) Then
                dic(a(i, 1)) = Empty
                .AutoFilter 1, a(i, 1)
                temp = .Parent.Evaluate("subtotal(3," & .Columns(1).Address & ")")
                If temp > 2 Then
                    If x Is Nothing Then
                        .Copy Sheets("sheet2").Cells(1)
                        Set x = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(12)
                    Else
                        .Offset(1).Resize(.Rows.Count - 1).Copy _
                        Sheets("sheet2").Range("a" & Rows.Count).End(xlUp)(2)
                    End If
                    Set x = Union(x, .Offset(1).Resize(.Rows.Count - 1).SpecialCells(12))
                End If
                .AutoFilter
            End If
        Next
        If Not x Is Nothing Then x.EntireRow.Delete
    End With
End Sub
 
Thanks, I'm going to try this, in the meantime I've gotten pretty close with this? but it's not letting me go to the next step? It's hanging in a loop at the end. Maybe with yours I won't need it.

Code: 
Sub container()
picknext
CopyDuplicates
final
End Sub

Sub picknext()
Sheets("Sheet2").Select
ActiveSheet.Range("a1", ActiveSheet.Range("a1").End(xlDown)).Select
End Sub

Sub CopyDuplicates()
'***************************************************************
'** This proc expects you to select all the cells in a single **
'** column that you want to check for duplicates in. If dup-  **
'** licates are found, the entire row will be copied to the  **
'** predetermined sheet.                                      **
'***************************************************************

Dim ShO As Worksheet
Dim Rng1 As Range
Dim pRow As Integer
Dim c As Range, cTmp As Range
Dim found
Dim Addresses() As String
Dim a() As String
Dim p2 As Integer
Dim tfFlag As Boolean, sTmp As Variant

Set ShO = Worksheets("duplicates") 'You can change this to whatever worksheet name you want the duplicates in
Set Rng1 = Application.Selection 'Rng1 is all the currently selected cells
pRow = 1 'This is the first row in our outpur sheet that will be used to record duplicates
ReDim a(0) 'Initialize our array that holds found values

For Each c In Rng1.Cells 'Cycle through each cell in our selected range
ReDim Addresses(0) 'This array holds the cell address for our duplicates.
                  'We will reset the array each time we move to the next cell

'Now check the array of already found duplicates.
'If the current value is already there skip to next value
tfFlag = False
For Each sTmp In a
    If CStr(c.Value) = sTmp Or CStr(c.Value) = "xXDeleteXx" Then 'We've already done this value, move on
        tfFlag = True
        Exit For
    End If
Next

    If Not tfFlag Then 'Remember the flag is true when we have already located the
                      'duplicates for this value, so skip to next value
        With Rng1
            Set found = .Find(c.Value, LookIn:=xlValues) 'Search entire selected range for value
            If Not found Is Nothing Then 'Found it
                Addresses(0) = found.Address 'Record the address we found it
                Do 'Now keep finding occurances of it
                    Set found = .FindNext(found)
                    If found.Address <> Addresses(0) Then
                        ReDim Preserve Addresses(UBound(Addresses) + 1)
                        Addresses(UBound(Addresses)) = found.Address
                    End If
                Loop While Not found Is Nothing And found.Address <> Addresses(0) 'Until we get back to the original address

                If UBound(Addresses) > 0 Then 'We Found Duplicates
                    a(UBound(a)) = c.Value 'Record the value we found a duplicate for in an array
                    ReDim Preserve a(UBound(a) + 1) 'add an empty spot to the array for next value
                   
                    pRow = pRow + 1 'Increment to the next row
                    For p2 = UBound(Addresses) To 0 Step -1 'Cycle through the duplicate addresses
                        Set cTmp = Rng1.Worksheet.Range(Addresses(p2)) 'we just want to easily get the correct row to copy
                        Rng1.Worksheet.Rows(cTmp.Row).Copy ShO.Rows(pRow) 'Copy form orig to duplicates sheet
                            cTmp.Value = "xXDeleteXx" 'Mark for Delete the original row
                        pRow = pRow + 1 'Increment row counter
                    Next p2
                    pRow = pRow + 1 'This increment will give us a blank row between sets of dupicates
                End If
            End If
        End With
    End If
Next
'Now go delete all the marked rows

Do
tfFlag = False
For Each c In Rng1
    If c.Value = "xXDeleteXx" Then
        Rng1.Worksheet.Rows(c.Row).Delete (xlShiftUp)
        tfFlag = True
    End If
Next
Loop Until tfFlag = False

End
MsgBox "hello"
End Sub

Sub final()
    MsgBox "almost"
    Sheets("Duplicates").Select
    ActiveSheet.UsedRange.Copy
    Sheets("DupsbyLoc").Select
    Range("A1").Select
    ActiveSheet.Paste
End Sub

I can't upload for some reason? will try in another post
 
Here is the CSV version at least, I had two other sheets, as well
Code: 
PICKTKT,PICKTKT,AISLE,RW,BIN,STYLE,Size,Qty,SHIP_VIA,ORDER_NO,ORDER_NO
36070,36070,15,4,1,A8143,MN sz: 4,1,FEDEXHM,69661,69661
36070,36070,10,2,3,A8956,WO sz: 6,1,FEDEXHM,69661,69661
36071,36071,11,1,2,A6061,MN sz: 9,1,FEDEXHM,69662,69662
36071,36071,23,7,102,A6142,MN sz: 9,1,FEDEXHM,69662,69662
36072,36072,12,1,1,A6063,MN sz: 12,1,FEDEXHM,69690,69690
36072,36072,10,1,1,A8833,MN sz: 12,1,FEDEXHM,69690,69690
36073,36073,15,3,2,A8639,MN sz: 6,1,FEDEXHM,69701,69701
36073,36073,7,1,2,V8865,MN sz: 6,1,FEDEXHM,69701,69701
36074,36074,17,2,2,A8649,MN sz: 5,1,FEDEXHM,69713,69713
36074,36074,16,6,1,A8934L,WO sz: 7,1,FEDEXHM,69713,69713
36075,36075,1,3,1,A8018,MN sz: 9,1,FEDEXHM,69723,69723
36075,36075,1,1,3,A8072,MN sz: 9,1,FEDEXHM,69723,69723
36076,36076,1,1,3,A8072,MN sz: 10,1,FEDEXHM,69729,69729
36076,36076,14,3,3,A9008L,WO sz: 6,1,FEDEXHM,69729,69729
36077,36077,15,5,1,A9043L,WO sz: 6,1,FEDEXHM,69742,69742
36077,36077,1,2,2,V8356,MN sz: 4,1,FEDEXHM,69742,69742
36078,36078,28,12,101,A8653,MN sz: 4,1,UPSSUREPST,69659,69659
36079,36079,24,11,102,A8686L,WO sz: 11,1,UPSSUREPST,69660,69660
36080,36080,13,1,1,V8892,MN sz: 9,1,UPSSUREPST,69663,69663
36081,36081,8,6,4,A8582,MN sz: 9,1,UPSSUREPST,69664,69664
36082,36082,11,3,2,A6293,MN sz: 6,1,UPSSUREPST,69666,69666
36083,36083,26,12,101,A8885,WO sz: 10,1,UPSSUREPST,69668,69668
36084,36084,1,1,3,A7976,MN sz: 12,1,UPSSUREPST,69670,69670
36085,36085,11,5,2,A8853L,WO sz: 6,1,UPSSUREPST,69673,69673
36086,36086,15,5,1,A9043L,WO sz: 8,1,UPSSUREPST,69674,69674
36087,36087,10,4,1,A9028,MN sz: 4,1,UPSSUREPST,69675,69675
36088,36088,26,8,102,A8976L,WO sz: 9,1,UPSSUREPST,69676,69676
36089,36089,1,1,1,A6072,MN sz: 11,1,UPSSUREPST,69679,69679
36090,36090,1,1,2,A6802,MN sz: 7,1,UPSSUREPST,69680,69680
36091,36091,26,12,101,A8885,WO sz: 6,1,UPSSUREPST,69681,69681
36092,36092,15,5,1,A9043L,WO sz: 5,1,UPSSUREPST,69683,69683
36093,36093,1,1,1,A8022,MN sz: 9,1,UPSSUREPST,69684,69684
36094,36094,17,5,1,A8664L,WO sz: 7,1,UPSSUREPST,69685,69685
36095,36095,21,6,2,A8822,MN sz: 8,1,UPSSUREPST,69686,69686
36096,36096,15,5,1,A9043L,WO sz: 11,1,UPSSUREPST,69688,69688
36097,36097,27,10,101,A8142,MN sz: 8,1,UPSSUREPST,69689,69689
36098,36098,16,6,3,A8523,MN sz: 7,1,UPSSUREPST,69691,69691
36099,36099,1,1,4,A8676L,WO sz: 11,1,UPSSUREPST,69692,69692
36100,36100,1,1,2,A8550,MN sz: 8,1,UPSSUREPST,69695,69695
36101,36101,26,9,102,A8649,MN sz: 6,1,UPSSUREPST,69698,69698
36102,36102,1,1,4,A7898,MN sz: 4,1,UPSSUREPST,69700,69700
36103,36103,18,3,2,A9032L,WO sz: 9,1,UPSSUREPST,69705,69705
36104,36104,21,3,3,V6804,MN sz: 10,1,UPSSUREPST,69707,69707
36105,36105,28,13,102,A9064L,WO sz: 8,1,UPSSUREPST,69714,69714
36106,36106,9,1,2,A9011L,WO sz: 9,1,UPSSUREPST,69715,69715
36107,36107,13,1,4,V8501,MN sz: 6,1,UPSSUREPST,69716,69716
36108,36108,25,9,101,T2025,WO sz: 8,1,UPSSUREPST,69717,69717
36109,36109,16,1,1,A8813L,WO sz: 6,1,UPSSUREPST,69718,69718
36110,36110,25,5,101,A8520,MN sz: 7,1,UPSSUREPST,69719,69719
36111,36111,31,4,101,A8887,WO sz: 9,1,UPSSUREPST,69720,69720
36112,36112,18,4,2,A9038L,WO sz: 9,1,UPSSUREPST,69727,69727
36113,36113,21,4,4,V8991,MN sz: 6,1,UPSSUREPST,69730,69730
36114,36114,28,6,101,A8994L,WO sz: 7,1,UPSSUREPST,69731,69731
36115,36115,1,2,3,A8662L,WO sz: 11,1,UPSSUREPST,69733,69733
36116,36116,4,5,3,A8831,MN sz: 9,1,UPSSUREPST,69734,69734
36117,36117,6,4,1,V9035,MN sz: 3,1,UPSSUREPST,69736,69736
36118,36118,18,5,2,A8533,MN sz: 9,1,UPSSUREPST,69737,69737
36119,36119,23,14,102,A8956,WO sz: 7,1,UPSSUREPST,69738,69738
36120,36120,9,6,3,A9009L,WO sz: 10,1,UPSSUREPST,69741,69741
36121,36121,18,6,4,A8520,MN sz: 12,1,UPSSUREPST,69743,69743
36122,36122,27,14,101,V9061,MN sz: 10,1,USPSPRI,69665,69665
36123,36123,1,1,2,A6802,MN sz: 7,1,USPSPRI,69667,69667
36123,36123,26,9,101,A8482,MN sz: 7,1,USPSPRI,69667,69667
36124,36124,21,3,4,A8078L,WO sz: 7,1,USPSPRI,69669,69669
36124,36124,9,4,4,A8231L,WO sz: 7,1,USPSPRI,69669,69669
36124,36124,11,2,1,A8230L,WO sz: 7,1,USPSPRI,69669,69669
36124,36124,2,3,4,A8178L,WO sz: 7,1,USPSPRI,69669,69669
36125,36125,14,5,3,A7691,MN sz: 6,1,USPSPRI,69677,69677
36126,36126,20,6,1,A8936L,WO sz: 8,1,USPSPRI,69678,69678
36127,36127,11,3,2,A6293,MN sz: 7,1,USPSPRI,69682,69682
36128,36128,21,4,2,V6806,MN sz: 6,1,USPSPRI,69693,69693
36129,36129,22,12,101,A6804,MN sz: 5,1,USPSPRI,69694,69694
36130,36130,19,2,3,V7757,MN sz: 4,1,USPSPRI,69696,69696
36131,36131,17,3,1,V9016,MN sz: 9,1,USPSPRI,69699,69699
36132,36132,1,1,1,V9093L,WO sz: 8,1,USPSPRI,69702,69702
36133,36133,1,1,2,A6802,MN sz: 7,1,USPSPRI,69703,69703
36134,36134,9,3,4,A8127,MN sz: 13,1,USPSPRI,69706,69706
36135,36135,0,0,0,A9028,MN sz: 6,1,USPSPRI,69709,69709
36136,36136,19,4,1,V8463,MN sz: 5,1,USPSPRI,69724,69724
36137,36137,10,2,4,A8956,WO sz: 9,1,USPSPRI,69725,69725
36138,36138,16,5,1,V9053,MN sz: 6,1,USPSPRI,69728,69728
36139,36139,23,11,102,A8284,MN sz: 10,1,USPSPRI,69732,69732
36139,36139,11,6,3,A8128,MN sz: 10,1,USPSPRI,69732,69732
36140,36140,9,6,1,A8996,MN sz: 6,1,USPSPRI,69735,69735
36141,36141,11,3,3,A9044L,WO sz: 7,1,USPSPRI,69739,69739
 
CSV to CSV?
Code: 
Sub test()
    Dim fn As String, txt As String, dic As Object, myID, x, i, e
    fn = Application.GetOpenFilename("CSVFiles,*.csv")
    If fn = "False" Then Exit Sub
    txt = Space(FileLen(fn))
    Open fn For Binary As #1
        Get #1, , txt
    Close #1
    x = Split(txt, vbCrLf)
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(x)
            myID = Split(x(i), ",")(0)
            If Not .exists(myID) Then
                Set .Item(myID) = CreateObject("System.Collections.ArrayList")
            End If
            .Item(myID).Add CStr(x(i))
        Next
        For Each e In .keys
            If .Item(e).Count > 1 Then
                .Remove e
            Else
                .Item(e) = Join(.Item(e).ToArray, vbCrLf)
            End If
        Next
        txt = Join(Array(x(0), Join(.items, vbCrLf)), vbCrLf)
    End With
    If Len(txt) Then
        Open Replace(fn, ".csv", "_Revised.csv") For Output As #1
            Print #1, txt
        Close #1
    End If
End Sub
 
You must log in or register to reply here.
Back
Top