How to edit this copy and paste VBA code to include duplicate values?

[Indominus]

Hello. So I have two workbooks here. I have attached screenshots of both. One is Pickorder. Column A lists the dispatch times. Column B has route codes. Column D has the dispatch areas. Column E has the dsp taking the route. For example, CX19 dispatches at 6:15:00, at STG.A01 for HIQL. I then have this Wave planner sheet. This VBA code copies and pastes the route codes (column B) into the correct time column on the Wave Planner matching the staging location and dsp. However, the Pickorder I receive daily has duplicate staging locations at different times. For example route codes that dispatch at 8:15:00 have dispatch area A also and start at STG.A01. Whenever I run the macro it gives me error code '457', "this key is already associated with an element of this collection."

This code works perfectly if there are no duplicate dispatch zones. Attached is an image of how the wave planner should look like after the route codes are copied and pasted in this example. How would I edit this code to match the criteria's of the dispatch time along with the staging area and dsp? Thank you to anyone willing to help me. Here is the full code I have now.

Sub CopyPasteDuplicates()

    Dim bk As Workbook, Sht As Worksheet
  Dim dict As Object, ky As Variant
  Dim cell As Range, f As Range, c As Range
 
  For Each bk In Application.Workbooks
    If UCase(bk.Name) Like UCase("*Pick*order*") Then Exit For
  Next bk
 
  If bk Is Nothing Then
    MsgBox "Workbook not found", vbCritical
    Exit Sub
  End If
 
  Set dict = CreateObject("scripting.dictionary")
 
  For Each cell In bk.Sheets(1).Range("B2:B" & bk.Sheets(1).Range("B1048576").End(xlUp).Row)
        If dict.Exists(Trim$(cell.Offset(0, 2).Value2)) Then
           MsgBox "Duplicate staging areas detected. Identify duplicate staging area in Column D of Pickorder and insert unique staging area. Input linked route code into Wave Plan"
        Else
           dict.Add Trim$(cell.Offset(0, 2).Value2), Array(abbrev_dsp(cell.Offset(0, 3).Value2), cell.Value2)
        End If
    Next cell

 
  If dict.Count = 0 Then
    MsgBox "Data not found", vbCritical
    Exit Sub
  End If
 
  Set Sht = ThisWorkbook.Sheets("C1 Wave Plan")
  For Each ky In dict.keys
    Set f = Sht.Cells.Find(ky, , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then
      If dict(Trim$(ky))(0) = "" Then
        f.Offset(0, 1).Value = dict(Trim$(ky))(1)
      Else
        Set c = Sht.Range(Sht.Cells(3, f.Column), Sht.Cells(3, f.Column + 6)).Find(dict(Trim$(ky))(0), , xlValues, xlWhole, , , False)
        If Not c Is Nothing Then
          Sht.Cells(f.Row, c.Column).Value = dict(Trim$(ky))(1)
        End If
      End If
    End If
  Next ky
 
End Sub
'********
Function abbrev_dsp(dspCode As String) As String
  Select Case Trim$(dspCode)
    Case "AROW"
      dspCode = "AW"
    Case "JPDG"
      dspCode = "JP"
    Case "HIQL"
      dspCode = "HQ"
  End Select
  abbrev_dsp = Trim$(dspCode)
End Function

 

[ExcelGzh]

I don't know anything about scripting dictionaries and how they are used, but it seems to me that what you are doing is copying data from the Auto Picker into the dictionary and then copying the data out of the dictionary into the Waveplan. I'm thinking why not go directly from the Auto Picker to the Waveplan? As you read each line in the Auto Picker, use the cell references to find the appropriate place in the Wave Plan, copy the data into the Wave Plan and then go back around. If that makes the code a bit complicated you could put the data from the Auto Picker into some temporary variables and then re-populate the variables on each loop.

The problem is with the transport mechanism (the dictionary) not the final destination, so get rid of the transport mechanism.

 

[Indominus]

I don't know anything about scripting dictionaries and how they are used, but it seems to me that what you are doing is copying data from the Auto Picker into the dictionary and then copying the data out of the dictionary into the Waveplan. I'm thinking why not go directly from the Auto Picker to the Waveplan? As you read each line in the Auto Picker, use the cell references to find the appropriate place in the Wave Plan, copy the data into the Wave Plan and then go back around. If that makes the code a bit complicated you could put the data from the Auto Picker into some temporary variables and then re-populate the variables on each loop.

The problem is with the transport mechanism (the dictionary) not the final destination, so get rid of the transport mechanism.

So the Pickorder is unique and changes daily

 

[ExcelGzh]

Try this. Instead of running two loops, one to copy data from the PickOrder sheet into the dictionary and then another copy to copy the data back out of the dictionary into the WavePlan, this copies the PickOrder data straight into the WavePlan. I think the dispatch area error will disappear because that is caused by the use of the dictionary. However with no dictionary you will need to work out some other way of discovering the duplicate staging areas error. Perhaps redefine the dictionary definition so that it doesn't contain the dispatch area.

Option Explicit

Sub CopyPasteDuplicates()

  Dim bk As Workbook, Sht As Worksheet
'  Dim dict As Object, ky As Variant
  Dim cell As Range, f As Range, c As Range
  Dim RouteCode As String
  Dim DispatchArea As String
  Dim dsp As String
 
  For Each bk In Application.Workbooks
    If UCase(bk.Name) Like UCase("*Pick*order*") Then Exit For
  Next bk
 
  If bk Is Nothing Then
    MsgBox "Workbook not found", vbCritical
    Exit Sub
  End If
 
'  Set dict = CreateObject("scripting.dictionary")
  Set Sht = ThisWorkbook.Sheets("C1 Wave Plan")
 
  For Each cell In bk.Sheets(1).Range("B2:B" & bk.Sheets(1).Range("B1048576").End(xlUp).Row)
'        If dict.Exists(Trim$(cell.Offset(0, 2).Value2)) Then
'           MsgBox "Duplicate staging areas detected. Identify duplicate staging area in Column D of Pickorder and insert unique staging area. Input linked route code into Wave Plan"
'        Else
'           dict.Add Trim$(cell.Offset(0, 2).Value2), Array(abbrev_dsp(cell.Offset(0, 3).Value2), cell.Value2)
          RouteCode = cell
          DispatchArea = cell.Offset(0, 2)
          dsp = abbrev_dsp(cell.Offset(0, 3).Value2)
          Set f = Sht.Cells.Find(DispatchArea, , xlValues, xlWhole, , , False)
          If Not f Is Nothing Then
            If RouteCode = "" Then
              f.Offset(0, 1).Value = DispatchArea
            Else
              Set c = Sht.Range(Sht.Cells(3, f.Column), Sht.Cells(3, f.Column + 6)).Find(dsp, , xlValues, xlWhole, , , False)
              If Not c Is Nothing Then
                Sht.Cells(f.Row, c.Column).Value = RouteCode
              End If
            End If
          End If
'        End If
    Next cell
 
'  If dict.Count = 0 Then
'    MsgBox "Data not found", vbCritical
'    Exit Sub
'  End If
 
End Sub
'********
Function abbrev_dsp(dspCode As String) As String
  Select Case Trim$(dspCode)
    Case "AROW"
      dspCode = "AW"
    Case "JPDG"
      dspCode = "JP"
    Case "HIQL"
      dspCode = "HQ"
  End Select
  abbrev_dsp = Trim$(dspCode)
End Function

 

[Indominus]

Try this. Instead of running two loops, one to copy data from the PickOrder sheet into the dictionary and then another copy to copy the data back out of the dictionary into the WavePlan, this copies the PickOrder data straight into the WavePlan. I think the dispatch area error will disappear because that is caused by the use of the dictionary. However with no dictionary you will need to work out some other way of discovering the duplicate staging areas error. Perhaps redefine the dictionary definition so that it doesn't contain the dispatch area.

Option Explicit

Sub CopyPasteDuplicates()

  Dim bk As Workbook, Sht As Worksheet
'  Dim dict As Object, ky As Variant
  Dim cell As Range, f As Range, c As Range
  Dim RouteCode As String
  Dim DispatchArea As String
  Dim dsp As String

  For Each bk In Application.Workbooks
    If UCase(bk.Name) Like UCase("*Pick*order*") Then Exit For
  Next bk

  If bk Is Nothing Then
    MsgBox "Workbook not found", vbCritical
    Exit Sub
  End If

'  Set dict = CreateObject("scripting.dictionary")
  Set Sht = ThisWorkbook.Sheets("C1 Wave Plan")

  For Each cell In bk.Sheets(1).Range("B2:B" & bk.Sheets(1).Range("B1048576").End(xlUp).Row)
'        If dict.Exists(Trim$(cell.Offset(0, 2).Value2)) Then
'           MsgBox "Duplicate staging areas detected. Identify duplicate staging area in Column D of Pickorder and insert unique staging area. Input linked route code into Wave Plan"
'        Else
'           dict.Add Trim$(cell.Offset(0, 2).Value2), Array(abbrev_dsp(cell.Offset(0, 3).Value2), cell.Value2)
          RouteCode = cell
          DispatchArea = cell.Offset(0, 2)
          dsp = abbrev_dsp(cell.Offset(0, 3).Value2)
          Set f = Sht.Cells.Find(DispatchArea, , xlValues, xlWhole, , , False)
          If Not f Is Nothing Then
            If RouteCode = "" Then
              f.Offset(0, 1).Value = DispatchArea
            Else
              Set c = Sht.Range(Sht.Cells(3, f.Column), Sht.Cells(3, f.Column + 6)).Find(dsp, , xlValues, xlWhole, , , False)
              If Not c Is Nothing Then
                Sht.Cells(f.Row, c.Column).Value = RouteCode
              End If
            End If
          End If
'        End If
    Next cell

'  If dict.Count = 0 Then
'    MsgBox "Data not found", vbCritical
'    Exit Sub
'  End If

End Sub
'********
Function abbrev_dsp(dspCode As String) As String
  Select Case Trim$(dspCode)
    Case "AROW"
      dspCode = "AW"
    Case "JPDG"
      dspCode = "JP"
    Case "HIQL"
      dspCode = "HQ"
  End Select
  abbrev_dsp = Trim$(dspCode)
End Function

So this does copy and paste everything fine. And does not give the error. However, the duplicate values do not get copied over still and I really need them to. Do you know if it is possible? I am fairly new to VBA and cannot find anything when I research this topic. Thank you for your help!

 

[ExcelGzh]

I think this code may do what you require. It looks for the occurrence of the dispatch time, then looks for a matching staging area starting with the column 1 to the left of the found dispatch time column, then looks for the dispatcher starting with the column 1 to the left of the found dispatch time column. The only way this will fail is if you have the same dispatcher using the same staging area at the same time. Impossible I would think.

Sub CopyPasteDuplicates()

  Dim bk As Workbook, Sht As Worksheet
'  Dim dict As Object, ky As Variant
  Dim cell As Range, f As Range, c As Range, t As Range
  Dim RouteCode As String
  Dim DispatchArea As String
  Dim dsp As String
  Dim DspTime As Double
 
  For Each bk In Application.Workbooks
    If UCase(bk.Name) Like UCase("*Pick*order*") Then Exit For
  Next bk
 
  If bk Is Nothing Then
    MsgBox "Workbook not found", vbCritical
    Exit Sub
  End If
 
'  Set dict = CreateObject("scripting.dictionary")
  Set Sht = ThisWorkbook.Sheets("C1 Wave Plan")
 
  For Each cell In bk.Sheets(1).Range("A2:A" & bk.Sheets(1).Range("A1048576").End(xlUp).Row)
'        If dict.Exists(Trim$(cell.Offset(0, 2).Value2)) Then
'           MsgBox "Duplicate staging areas detected. Identify duplicate staging area in Column D of Pickorder and insert unique staging area. Input linked route code into Wave Plan"
'        Else
'           dict.Add Trim$(cell.Offset(0, 2).Value2), Array(abbrev_dsp(cell.Offset(0, 3).Value2), cell.Value2)
          DspTime = cell 
          RouteCode = cell.Offset(0, 1)
          DispatchArea = cell.Offset(0, 3)
          dsp = abbrev_dsp(cell.Offset(0, 4).Value2)
          For Each t In Sht.Range("2:2")
          If DspTime Like t Then Exit For
          Next
          Set f = Sht.Range(Sht.Cells(t.Row, t.Column - 1), Sht.Cells(1000, 100)).Find(DispatchArea, , xlValues, xlWhole, , , False) 
          If Not f Is Nothing Then
            If RouteCode = "" Then
              f.Offset(0, 1).Value = DispatchArea
            Else
              Set c = Sht.Range(Sht.Cells(3, t.Column - 1), Sht.Cells(3, 100)).Find(dsp, , xlValues, xlWhole, , , False)
              If Not c Is Nothing Then
                Sht.Cells(f.Row, c.Column).Value = RouteCode
              End If
            End If
          End If
'        End If
    Next cell
 
'  If dict.Count = 0 Then
'    MsgBox "Data not found", vbCritical
'    Exit Sub
'  End If
 
End Sub

 

[Indominus]

I think this code may do what you require. It looks for the occurrence of the dispatch time, then looks for a matching staging area starting with the column 1 to the left of the found dispatch time column, then looks for the dispatcher starting with the column 1 to the left of the found dispatch time column. The only way this will fail is if you have the same dispatcher using the same staging area at the same time. Impossible I would think.

Sub CopyPasteDuplicates()

  Dim bk As Workbook, Sht As Worksheet
'  Dim dict As Object, ky As Variant
  Dim cell As Range, f As Range, c As Range, t As Range
  Dim RouteCode As String
  Dim DispatchArea As String
  Dim dsp As String
  Dim DspTime As Double

  For Each bk In Application.Workbooks
    If UCase(bk.Name) Like UCase("*Pick*order*") Then Exit For
  Next bk

  If bk Is Nothing Then
    MsgBox "Workbook not found", vbCritical
    Exit Sub
  End If

'  Set dict = CreateObject("scripting.dictionary")
  Set Sht = ThisWorkbook.Sheets("C1 Wave Plan")

  For Each cell In bk.Sheets(1).Range("A2:A" & bk.Sheets(1).Range("A1048576").End(xlUp).Row)
'        If dict.Exists(Trim$(cell.Offset(0, 2).Value2)) Then
'           MsgBox "Duplicate staging areas detected. Identify duplicate staging area in Column D of Pickorder and insert unique staging area. Input linked route code into Wave Plan"
'        Else
'           dict.Add Trim$(cell.Offset(0, 2).Value2), Array(abbrev_dsp(cell.Offset(0, 3).Value2), cell.Value2)
          DspTime = cell
          RouteCode = cell.Offset(0, 1)
          DispatchArea = cell.Offset(0, 3)
          dsp = abbrev_dsp(cell.Offset(0, 4).Value2)
          For Each t In Sht.Range("2:2")
          If DspTime Like t Then Exit For
          Next
          Set f = Sht.Range(Sht.Cells(t.Row, t.Column - 1), Sht.Cells(1000, 100)).Find(DispatchArea, , xlValues, xlWhole, , , False)
          If Not f Is Nothing Then
            If RouteCode = "" Then
              f.Offset(0, 1).Value = DispatchArea
            Else
              Set c = Sht.Range(Sht.Cells(3, t.Column - 1), Sht.Cells(3, 100)).Find(dsp, , xlValues, xlWhole, , , False)
              If Not c Is Nothing Then
                Sht.Cells(f.Row, c.Column).Value = RouteCode
              End If
            End If
          End If
'        End If
    Next cell

'  If dict.Count = 0 Then
'    MsgBox "Data not found", vbCritical
'    Exit Sub
'  End If

End Sub

Hello. So upon adding the dsp function code at the bottom this pastes some route codes into the Wave Plan but not correctly. And many are missing. It seems it is pasting them two columns over in the same exact cells with the Staging location numbers. Here are two screenshots. The Pickorder. And a screenshot showing where it pastes in the route codes. Once again thank you so much for your help.

 

[ExcelGzh]

That's very peculiar because I have recreated the layout of your spreadsheets exactly and I get the right result. Did you copy across all of the code I posted? For example, for the second posting of the code I changed the search at the start from column B to column A and then changed the cell offsets that set the values for DspTime, RouteCode, DispatchArea and dsp.

Perhaps if you could post back what code you currently have I might be able to spot an error somewhere.

 

[Indominus]

That's very peculiar because I have recreated the layout of your spreadsheets exactly and I get the right result. Did you copy across all of the code I posted? For example, for the second posting of the code I changed the search at the start from column B to column A and then changed the cell offsets that set the values for DspTime, RouteCode, DispatchArea and dsp.

Perhaps if you could post back what code you currently have I might be able to spot an error somewhere.

Hello. Just tried it again and the same thing happened. Here is the full code. The one from your second posting. I had to add the Function at the bottom for DSP abbreviations.

Sub CopyPasteDuplicates()

  Dim bk As Workbook, Sht As Worksheet
'  Dim dict As Object, ky As Variant
  Dim cell As Range, f As Range, c As Range, t As Range
  Dim RouteCode As String
  Dim DispatchArea As String
  Dim dsp As String
  Dim DspTime As Double

  For Each bk In Application.Workbooks
    If UCase(bk.Name) Like UCase("*Pick*order*") Then Exit For
  Next bk

  If bk Is Nothing Then
    MsgBox "Workbook not found", vbCritical
    Exit Sub
  End If

'  Set dict = CreateObject("scripting.dictionary")
  Set Sht = ThisWorkbook.Sheets("C1 Wave Plan")

  For Each cell In bk.Sheets(1).Range("A2:A" & bk.Sheets(1).Range("A1048576").End(xlUp).Row)
'        If dict.Exists(Trim$(cell.Offset(0, 2).Value2)) Then
'           MsgBox "Duplicate staging areas detected. Identify duplicate staging area in Column D of Pickorder and insert unique staging area. Input linked route code into Wave Plan"
'        Else
'           dict.Add Trim$(cell.Offset(0, 2).Value2), Array(abbrev_dsp(cell.Offset(0, 3).Value2), cell.Value2)
          DspTime = cell
          RouteCode = cell.Offset(0, 1)
          DispatchArea = cell.Offset(0, 3)
          dsp = abbrev_dsp(cell.Offset(0, 4).Value2)
          For Each t In Sht.Range("2:2")
          If DspTime Like t Then Exit For
          Next
          Set f = Sht.Range(Sht.Cells(t.Row, t.Column - 1), Sht.Cells(1000, 100)).Find(DispatchArea, , xlValues, xlWhole, , , False)
          If Not f Is Nothing Then
            If RouteCode = "" Then
              f.Offset(0, 1).Value = DispatchArea
            Else
              Set c = Sht.Range(Sht.Cells(3, t.Column - 1), Sht.Cells(3, 100)).Find(dsp, , xlValues, xlWhole, , , False)
              If Not c Is Nothing Then
                Sht.Cells(f.Row, c.Column).Value = RouteCode
              End If
            End If
          End If
'        End If
    Next cell

'  If dict.Count = 0 Then
'    MsgBox "Data not found", vbCritical
'    Exit Sub
'  End If

End Sub
'********
Function abbrev_dsp(dspCode As String) As String
  Select Case Trim$(dspCode)
    Case "AROW"
      dspCode = "AW"
    Case "JPDG"
      dspCode = "JP"
    Case "HIQL"
      dspCode = "HQ"
  End Select
  abbrev_dsp = Trim$(dspCode)
End Function

 

[ExcelGzh]

I've had a look at the code and it's identical to mine, so the next step is look at the spreadsheets themselves. You will need to have installed the XL2BB Excel add-on to do this. If you haven't it is available here XL2BB Select all the cells that have values in Sheet(1) on the Pick Order workbook, run the XL2BB add-in (select all the options) and then paste it here. Do the same for the C1 Wave Plan sheet. I'll then have a look to see if there any differences between your spreadsheets and the ones I constructed.

I have assumed from reading your code that Sheet(1) and C1 Wave Plan are in different workbooks.