Incorrect insertion of data from the dictionary-CodePudding

I have Excel with data.

I wrote a code that allows me to filter data depending on the company.

Sub testProjectMl()
    
    Dim sh As Worksheet, shDest As Worksheet, lastRow As Long, firstRow As Long, lastERowDest As Long
    Dim i As Long, arrA, dictKP As Object
    
    'Create a variable
    Dim dictKS
    Dim dictVT
    Dim dictAK
    Dim dictPP
 
    Set sh = ActiveSheet
    lastRow = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
    firstRow = 8 'first row with data
 
    arrA = sh.Range("A" & firstRow & ":A" & lastRow).Value 'place the range in an array for faster iteration
    Set dictKP = CreateObject("Scripting.Dictionary")
    Set dictKS = CreateObject("Scripting.Dictionary")
    Set dictVT = CreateObject("Scripting.Dictionary")
    Set dictPP = CreateObject("Scripting.Dictionary")
    Set dictAK = CreateObject("Scripting.Dictionary")
    
    With Sheets(ActiveSheet.Name)

    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
     For i = 8 To lastRow
        If IsNumeric(.Range("H" & i)) And Trim(.Range("H" & i).Value) <> "" And .Range("H" & i).Value <> 0 And .Range("H" & i).Value > 7000 Then
            Select Case True
                Case .Range("A" & i).Value Like "KP*"
                dictKP.Add .Range("A" & i).Value, Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
                               sh.Range(sh.Cells(i   firstRow - 1, "A"), sh.Cells(i   firstRow - 1, "K")))
                Case .Range("A" & i).Value Like "KS*"
                dictKS.Add .Range("A" & i).Value, Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
                               sh.Range(sh.Cells(i   firstRow - 1, "A"), sh.Cells(i   firstRow - 1, "K")))
                Case .Range("A" & i).Value Like "VT*"
                dictVT.Add .Range("A" & i).Value, Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
                               sh.Range(sh.Cells(i   firstRow - 1, "A"), sh.Cells(i   firstRow - 1, "K")))
                Case .Range("A" & i).Value Like "PP*"
                dictPP.Add .Range("A" & i).Value, Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
                               sh.Range(sh.Cells(i   firstRow - 1, "A"), sh.Cells(i   firstRow - 1, "K")))
                Case .Range("A" & i).Value Like "AK*"
                dictAK.Add .Range("A" & i).Value, Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
                               sh.Range(sh.Cells(i   firstRow - 1, "A"), sh.Cells(i   firstRow - 1, "K")))
            End Select
        End If
     Next i
    End With
    
    Sheets.Add.Name = "KP"
    Sheets.Add.Name = "KS"
    Sheets.Add.Name = "VT"
    Sheets.Add.Name = "PP"
    Sheets.Add.Name = "AK"
    
    Set shDestKp = Sheets("KP")
    Set shDestKs = Sheets("KS")
    Set shDestVt = Sheets("VT")
    Set shDestPp = Sheets("PP")
    Set shDestAk = Sheets("AK")
    
    For i = 0 To dictKP.Count - 1
    lastERowDest = shDestKp.Range("A" & shDestKp.Rows.Count).End(xlUp).Row   1
    If lastERowDest = 2 Then lastERowDest = 1
    dictKP.items()(i).Copy shDestKp.Range("A" & lastERowDest)
    shDestKp.Range("L" & lastERowDest).Value = "7000" ' insert a static franchise value
    shDestKp.Range("M" & lastERowDest).Value = "0.12" ' insert a static tarrif cost value
    shDestKp.Range("K" & lastERowDest).Copy ' copy the target format
    shDestKp.Range("L" & lastERowDest).PasteSpecial (xlPasteFormats) 'paste format into cell
    shDestKp.Range("M" & lastERowDest).PasteSpecial (xlPasteFormats)
    shDestKp.Range("N" & lastERowDest).PasteSpecial (xlPasteFormats)
    Application.CutCopyMode = False
    Next i
    
    For i = 0 To dictKS.Count - 1
    lastERowDest = shDestKs.Range("A" & shDestKs.Rows.Count).End(xlUp).Row   1
    If lastERowDest = 2 Then lastERowDest = 1
    dictKS.items()(i).Copy shDestKs.Range("A" & lastERowDest)
    shDestKs.Range("L" & lastERowDest).Value = "7000" ' insert a static franchise value
    shDestKs.Range("M" & lastERowDest).Value = "0.12" ' insert a static tarrif cost value
    shDestKs.Range("K" & lastERowDest).Copy ' copy the target format
    shDestKs.Range("L" & lastERowDest).PasteSpecial (xlPasteFormats) 'paste format into cell
    shDestKs.Range("M" & lastERowDest).PasteSpecial (xlPasteFormats)
    shDestKs.Range("N" & lastERowDest).PasteSpecial (xlPasteFormats)
    Application.CutCopyMode = False
    Next i
    
    For i = 0 To dictVT.Count - 1
    lastERowDest = shDestVt.Range("A" & shDestVt.Rows.Count).End(xlUp).Row   1
    'If lastERowDest = 2 Then lastERowDest = 1
    dictVT.items()(i).Copy shDestVt.Range("A" & lastERowDest)
    shDestVt.Range("L" & lastERowDest).Value = "7000" ' insert a static franchise value
    shDestVt.Range("M" & lastERowDest).Value = "0.12" ' insert a static tarrif cost value
    shDestVt.Range("K" & lastERowDest).Copy ' copy the target format
    shDestVt.Range("L" & lastERowDest).PasteSpecial (xlPasteFormats) 'paste format into cell
    shDestVt.Range("M" & lastERowDest).PasteSpecial (xlPasteFormats)
    shDestVt.Range("N" & lastERowDest).PasteSpecial (xlPasteFormats)
    Application.CutCopyMode = False
    Next i
    
    For i = 0 To dictPP.Count - 1
    lastERowDest = shDestPp.Range("A" & shDestPp.Rows.Count).End(xlUp).Row   1
    If lastERowDest = 2 Then lastERowDest = 1
    dictPP.items()(i).Copy shDestPp.Range("A" & lastERowDest)
    shDestPp.Range("L" & lastERowDest).Value = "7000" ' insert a static franchise value
    shDestPp.Range("M" & lastERowDest).Value = "0.12" ' insert a static tarrif cost value
    shDestPp.Range("K" & lastERowDest).Copy ' copy the target format
    shDestPp.Range("L" & lastERowDest).PasteSpecial (xlPasteFormats) 'paste format into cell
    shDestPp.Range("M" & lastERowDest).PasteSpecial (xlPasteFormats)
    shDestPp.Range("N" & lastERowDest).PasteSpecial (xlPasteFormats)
    Application.CutCopyMode = False
    Next i
    
    For i = 0 To dictAK.Count - 1
    lastERowDest = shDestAk.Range("A" & shDestAk.Rows.Count).End(xlUp).Row   1
    If lastERowDest = 2 Then lastERowDest = 1
    dictAK.items()(i).Copy shDestAk.Range("A" & lastERowDest)
    shDestAk.Range("L" & lastERowDest).Value = "7000" ' insert a static franchise value
    shDestAk.Range("M" & lastERowDest).Value = "0.12" ' insert a static tarrif cost value
    shDestAk.Range("K" & lastERowDest).Copy ' copy the target format
    shDestAk.Range("L" & lastERowDest).PasteSpecial (xlPasteFormats) 'paste format into cell
    shDestAk.Range("M" & lastERowDest).PasteSpecial (xlPasteFormats)
    shDestAk.Range("N" & lastERowDest).PasteSpecial (xlPasteFormats)
    Application.CutCopyMode = False
    Next i
End Sub

As you can see, depending on the value at the beginning of cell A, I adding the row in a certain dictionary. Then there is a cycle for each dictionary and inserting values into a specific sheets.

But I have a problem, for some reason the same line is entered in all the sheets when iterating through dictionaries.

For example (KS sheet):

This sheet should have the following value:

When Select Case and adding a row to the dictionary, the value in cell A is specified correctly and corresponds to a specific dictionary. BUT I don't understand why, when iterating through dictionaries, the same value from the dictKP dictionary is inserted.

Example what need in the end:

CodePudding user response：

Please, try using the next code. It needs only a single dictionary, creating keys based on the first two company name characters. It will add new sheets based on the dictionary keys and clear the existing if they exist:

Sub testProjectMl()
 Dim sh As Worksheet, newSh As Worksheet, lastRow As Long, firstRow As Long
 Dim i As Long, arrA, minVal As Double, dict As Object 

 Set sh = ActiveSheet
 lastRow = sh.Range("A" & sh.rows.count).End(xlUp).row
 firstRow = 7   'the row where the headers exist
 minVal = 7000  'you can change it (if another limit would be necessary)...

 arrA = sh.Range("A" & firstRow & ":K" & lastRow).value
 Set dict = CreateObject("Scripting.Dictionary")
 
 For i = 2 To UBound(arrA)  'iterate between the array rows:
    If IsNumeric(arrA(i, 8)) And Trim(arrA(i, 8)) <> "" And arrA(i, 8) <> 0 And arrA(i, 8) > minVal Then
        If Not dict.Exists(left(arrA(i, 1), 2)) Then
            dict.Add left(arrA(i, 1), 2), Union(sh.Range(sh.Range("A" & firstRow), sh.Range("K" & firstRow)), _
                                   sh.Range(sh.cells(i   firstRow - 1, "A"), sh.cells(i   firstRow - 1, "K")))
        Else
            Set dict(left(arrA(i, 1), 2)) = Union(dict(left(arrA(i, 1), 2)), _
                     sh.Range(sh.cells(i   firstRow - 1, "A"), sh.cells(i   firstRow - 1, "K")))
        End If
    End If
 Next i

 'drop the dictionary items content in the appropriate sheet (add it if not existing):
 Application.ScreenUpdating = False 'to make the code faster, when inserts sheet and copy ranges...
 Application.EnableEvents = False
 For i = 0 To dict.count - 1
    If Not sheetExists(CStr(dict.Keys()(i))) Then
        Set newSh = ActiveWorkbook.Sheets.Add(After:=sh) 'insert the sheet if it does not exist
        newSh.name = dict.Keys()(i)
    Else
        Set newSh = ActiveWorkbook.Sheets(dict.Keys()(i))'set the existing sheet and clear its content
        newSh.cells.ClearContents
    End If
    dict.items()(i).Copy newSh.Range("A1")               'copy the dictionary range
 Next i
End Sub

Function sheetExists(shName As String) As Boolean
   Dim ws As Worksheet
   For Each ws In ActiveWorkbook.Worksheets
        If ws.name = shName Then sheetExists = True: Exit Function
   Next ws
End Function