XL 2016 Collection object

mido21

XLDnaute Nouveau
Bonjour
Ce code ne fonctionne pas correctement
Quelle est l'idée qui corrige ce code?
VB:
Sub kind2()
    Sheet8.Range("b2:g10000").Clear
   With Application: .ScreenUpdating = False: .Calculation = xlCalculationManual: .EnableEvents = False: End With
    On Error Resume Next
    Dim ws As Worksheet
    Dim sh As Worksheet
    Dim a As Variant
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim gg As Long
    Dim collon_d As Collection, dd As Range
    Dim collon_b As Collection, bb As Range, rng As Range
    ''''''''''''''''''''''''''''''''''''''''''
    Set collon_d = New Collection
    Set collon_b = New Collection
    Set ws = sheet4
    Set sh = Sheet8
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
     a = ws.Range("b5:v" & ws.Cells(Rows.Count, 2).End(xlUp).Row)
    '===========================================================
    LsRow = ws.Range("h" & Rows.Count).End(xlUp).Row + 1
    For Each dd In ws.Range("j5:j" & LsRow)
        collon_d.Add dd.Value, dd.Text
    Next dd
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    LsRow2 = ws.Range("h" & Rows.Count).End(xlUp).Row + 1
    For Each bb In ws.Range("k5:k" & LsRow2)
        collon_b.Add bb.Value, bb.Text
    Next bb
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    For i = 1 To collon_d.Count
        ss = sh.Range("c" & Rows.Count).End(xlUp).Row
        sh.Range("b" & ss + 1) = collon_d(i)
        '---------------------------------------------------------------
        LsRow8 = sh.Range("b" & Rows.Count).End(xlUp).Row + 1
        r = LsRow8
       
        For g = 1 To collon_b.Count
            If CStr(a(g + 4, 9)) = CStr(collon_d(i)) Then
                sh.Range("c" & r).Value = CStr(collon_b(g))
               r = r + 1
            End If:
            '========================================
         Next g
            '=========================================================
     
    Next i
    '----------------------------------
   
    With Application: .ScreenUpdating = True: .Calculation = xlAutomatic: .EnableEvents = True: End With
End Sub
 

Fichiers joints

mido21

XLDnaute Nouveau
Bienvenue tout le monde
J'avais soulevé ce sujet il y a un moment
Je veux trier les données comme ça
group1
1234
578
555
group2
5456
5555
Et ainsi de suite
Code:
Sub kind3()
With Application: .ScreenUpdating = False: .Calculation = xlCalculationManual: .EnableEvents = False: End With
    On Error Resume Next
    Sheet8.Range("b2:g10000").Clear
    Dim ws, sh As Worksheet
    Dim a As Variant
    Dim i, j, k As Long
    Dim collon_d As Collection, dd As Range
    Set collon_d = New Collection: Set sh = Sheet8: Set ws = sheet4
   '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
     a = ws.Range("b5:v" & ws.Cells(Rows.Count, 2).End(xlUp).Row)
    LsRow = ws.Range("h" & Rows.Count).End(xlUp).Row + 1
    For Each dd In ws.Range("j5:j" & LsRow)
        collon_d.Add dd.Value, dd.Text
    Next dd
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    For i = 1 To collon_d.Count
    sh.AutoFilterMode = False
    LsRow22 = sh.Range("c" & Rows.Count).End(xlUp).Row + 1
     sh.Range("b" & LsRow22 + 2) = collon_d(i)
     sh.Range("k1").Value = collon_d(i)
   ws.Range("k5:k" & LsRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=sh.Range("k1"), CopyToRange:=sh.Range("c" & LsRow22 + 3), Unique:=True
   Next '========================================
   With Application: .ScreenUpdating = True: .Calculation = xlAutomatic: .EnableEvents = True: End With
End Sub
Le code appelle les données cependant
Je veux les données correspondantes pour groupe1
Code:
 ws.Range("k5:k" & LsRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=sh.Range("k1"), CopyToRange:=sh.Range("c" & LsRow22 + 3), Unique:=True
 

Discussions similaires


Haut Bas