How to get to this result?

Question

I want to achieve the following result in D:F

4 digit numbers are assigned to the correct number in column D, and every percentage in column F is assigned to the correct value in column E.

I used for the splitting part (fe. 40218 gets to 40 in column D & 0218 in column E) the following code, of course with a lot of help by this forum. The code is a called sub by a precending sub. I can not use both in combination anymore because i had change the precending code by its advanced filter (first it was filtered just on the output which you can see in column H, i adapted it and therefore column I & J were also submitted to the output range). Anyway it fine for me if i use H:J as my starting point. This just as a quick explanation why the sub splitByChars includes Paramaters ByRef & ByVal

So Range H:J is the new Start Point Zero.

Sub splitByChars( _
        ByRef rg As Range, _
        ByVal Chars As Long)
    
    Dim Data As Variant: Data = rg.Value
    Dim rCount As Long: rCount = UBound(Data, 1)
    Dim cCount As Long: cCount = 1
    
    Dim cSize As Long
    Dim r As Long, c As Long
    Dim iLen As Long, fLen As Long, rLen As Long
    Dim iString As String, rString As String
    

    For r = 1 To rCount
        iString = CStr(Data(r, 1))
        iLen = Len(iString)
        If iLen >= Chars Then
            fLen = iLen Mod Chars
            Data(r, 1) = Left(iString, fLen)
            rLen = iLen - fLen
            cSize = rLen / Chars + 1
            rString = Mid(iString, fLen + 1, rLen)
            If cSize > cCount Then
                cCount = cSize
                ReDim Preserve Data(1 To rCount, 1 To cSize)
            End If
            For c = 2 To cSize
                Data(r, c) = Mid(rString, (c - 2) * Chars + 1, Chars)
                Debug.Print r, c, Data(r, c)
            Next c
            
            Else
            Data(r, 1) = ""
            
        End If
    Next r
    
    With rg.Resize(, cCount)
        .NumberFormat = "@"
        .Value = Data
    End With
    
    On Error Resume Next
    
     With rg
    .Value = .Value
    .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
     End With
     
End Sub

The problem with this code is that all vales are missing in D which have less digits than 2. Chars were declared in the precending code =4 because in column E the number is always 4 digits length

• so Problem 1 arise: Not all values in D are shown up, because not all have 4 digits behind at least one digit in column H

• The second problem which arise is that even values in D which are unique show differences by their values in column I, so i can not sum up all values for example from 4 to 4, because the percentage from for example 40218 is 15% instead of 50% like for the other ones which are assigned to 4.

Its just really important for me that you all know that i really do not want to use your time for finding that one code which solves all. I'm a beginner, i understand day by day a bit more but this here is way over my undertanding and skills on logical and knwoledge level of VBA.

If there is any chance that you think this is quite easy, i really appreciate your help. If you say, "Guy this is impossible" also fine because then i can put it down and waste not more hours on that project. Also this hint helps more than you maybe can imagine.

Update 21.05.21 precending code on which splitByChars works

Sub Unique_Values_Worksheet_Variables()

'1 Code + Sub splitByChars
    
    Const Chars As Long = 4
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim sws As Worksheet: Set sws = wb.Worksheets("export")
    Dim dws As Worksheet:
    Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
    
    sws.Range("C:C").AdvancedFilter _
        Action:=xlFilterCopy, _
        CopyToRange:=dws.Range("A:A"), _
        Unique:=True
          
    dws.Columns("A:B").EntireColumn.AutoFit
    Dim rng As Range:
    Set rng = dws.Range("A1:B1", dws.Cells(dws.Rows.Count, 1).End(xlUp))
    rng.Borders(xlDiagonalDown).LineStyle = xlNone
    rng.HorizontalAlignment = xlCenter
    
    
    With rng.Borders()
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
        
    End With
    
    Cells(1, 1).Value = "Produktgruppe"
    Cells(1, 2).Value = "Serie"
    
    'folgend setzt Sub SplitByChars auf dieser Prozedur Unique_Values_Workesheet_Variables auf

    splitByChars rng.Resize(rng.Rows.Count - 1).Offset(1), Chars
    
    ActiveWindow.DisplayGridlines = False

End Sub

But like i said this precending code does not work anymore in combination with spliByChars because the Filter Method had to be adjusted

Sub Unique_Values_Worksheet_Variables()
    '1 Code + Sub splitByChars
    Const Chars As Long = 4
     
    'Dim wb As Workbook: Set wb = ThisWorkbook
    'Dim sws As Worksheet: Set sws = wb.Worksheets("export")
    
   ' Source
    Const sName As String = "export1"
    Const sUniqueColumn As String = "C"
    Const sCopyColumnsList As String = "C,I,J" ' exact order of the columns
    ' Destination (new worksheet)
    
    Const dFirst As String = "A1"
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim dws As Worksheet: Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
    
    Dim sCopyColumns() As String: sCopyColumns = Split(sCopyColumnsList, ",")
    Dim dCell As Range: Set dCell = dws.Range(dFirst)
    
    Application.ScreenUpdating = False
    
    Dim rng As Range
    With wb.Worksheets(sName).Range("A1").CurrentRegion
        .Columns(sUniqueColumn).AdvancedFilter xlFilterInPlace, , , True
        Dim n As Long
        For n = 0 To UBound(sCopyColumns)
            .Columns(sCopyColumns(n)).Copy dCell
            Set dCell = dCell.Offset(, 1)
        Next n
        .Parent.ShowAllData
    End With
    
    Application.ScreenUpdating = True
      
    dws.Columns("A:J").EntireColumn.AutoFit
    
    Set rng = dws.Range(dCell, dws.Cells(dws.Rows.Count, 1).End(xlUp))
    rng.Borders(xlDiagonalDown).LineStyle = xlNone
    rng.HorizontalAlignment = xlCenter
   
    'folgend setzt Sub SplitByChars auf dieser Prozedur Unique_Values_Workesheet_Variables auf

    splitByChars rng.Resize(rng.Rows.Count - 1).Offset(1), Chars
    
    ActiveWindow.DisplayGridlines = False

End Sub

and exactly like this it has to work

Answer 1

Option Explicit

Sub mymacro()

    Dim wb As Workbook, ws As Worksheet
    Dim iLastRow As Long, i As Long
    Dim sPcent As String, s As String, colD As String, colE As String
    Dim dict, key, ar

    Set wb = ThisWorkbook
    Set ws = wb.Sheets(1)
    Set dict = CreateObject("Scripting.Dictionary")

    ' process data
    iLastRow = ws.Cells(Rows.Count, "H").End(xlUp).Row
    For i = 3 To iLastRow
        s = ws.Cells(i, "H")
        sPcent = Format(ws.Cells(i, "I"), "0.00")
        If Len(s) > 4 Then
            colD = Left(s, Len(s) - 4)
            colE = Right(s, 4)
        Else
            colD = s
            colE = ""
        End If
        key = colD & vbTab & sPcent

        If dict.exists(key) Then
            If Len(colE) > 0 Then
                dict(key) = dict(key) & "," & colE
            End If
        Else
            dict.Add key, colE
        End If
    Next

    ' output result
    ws.Range("D1:G1") = Array("a", "b", "c", "d")
    ws.Columns("D:G").NumberFormat = "@"
    i = 2
    For Each key In dict.keys
        ar = Split(key, vbTab) 'colD,pcent
        ws.Cells(i, "D") = ar(0)
        ws.Cells(i, "E") = dict(key)
        ws.Cells(i, "F") = ar(1)
        ws.Cells(i, "G") = "%"
        i = i + 1
    Next
    MsgBox "Done"

End Sub