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
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas