***** Bu nedir? *****

Excel dersleri ile ilgili sormak istediklerinizi paylaşabileceğiniz alan

Cevap: ***** Bu nedir? *****

İleti#201)  gicimi » 19 May 2020 00:00

Merhaba;
Kodu açıklayabilir misiniz.

Kod: Tümünü seç
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
t = TimeValue(Now)
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")

Set s2 = Sheets("Sayfa1")
    b = s2.Range("A5:A" & s2.Cells(Rows.Count, 1).End(3).Row).Value
    ay = s2.[E2]
   
    For i = 1 To UBound(b)
    krt = CStr(b(i, 1))
    dc(krt) = krt
    Next i
     
    yol = ThisWorkbook.Path & "\Rapor\" & ay & "\"
    dosya = Dir(yol & "*.xlsx*")

        Do While dosya <> ""
            GetObject (yol & dosya)
            Set s1 = Workbooks(dosya).Sheets(1)
            a = s1.Range("A2:A" & s1.Cells(Rows.Count, 1).End(3).Row).Value
                For i = 1 To UBound(a)
                krt1 = CStr(a(i, 1))
                If dc.exists(krt1) Then
                    krt = CStr(a(i, 1)) & "#" & CStr(Left(dosya, 10))
                    d(krt) = 1
                    End If
                Next i
            Workbooks(dosya).Close
            dosya = Dir
        Loop
'================================

Set ds1 = CreateObject("scripting.dictionary")
Set ds2 = CreateObject("scripting.dictionary")
Set ds3 = CreateObject("scripting.dictionary")
Set ds4 = CreateObject("scripting.dictionary")
Set ds5 = CreateObject("scripting.dictionary")

    yols = ThisWorkbook.Path & "\Siparis\"
   
    dosyas = s2.[C2] & ".xlsx"

            GetObject (yols & dosyas)
            Set s3 = Workbooks(dosyas).Sheets(1)
            aa = s3.Range("C2:O" & s3.Cells(Rows.Count, "H").End(3).Row).Value
                For i = 1 To UBound(aa)
                krts = CStr(aa(i, 6))
                If ds1.exists(krts) Then
                    If aa(i, 1) > aa(ds1(krts), 1) Then
                        ds1(krts) = i
                    End If
                Else
                    ds1(krts) = i
                End If
                Next i
            Workbooks(dosyas).Close

    c = s2.Range("J4:AN4").Value
    ReDim w(1 To UBound(b), 1 To UBound(c, 2) + 6)
        For i = 1 To UBound(b)
            For j = 1 To UBound(c, 2)
                krt = CStr(b(i, 1)) & "#" & CStr(c(1, j))
                w(i, j) = d(krt)
                If w(i, j) = 1 Then w(i, 32) = w(i, 32) + 1
                krts = CStr(b(i, 1))
                If ds1.exists(krts) Then
                    w(i, 33) = aa(ds1(krts), 1)
                    w(i, 34) = aa(ds1(krts), 5)
                    w(i, 35) = aa(ds1(krts), 7)
                    w(i, 36) = aa(ds1(krts), 10)
                    w(i, 37) = aa(ds1(krts), 13)
                End If
            Next j
        Next i

    s2.[j5].Resize(UBound(b), UBound(c, 2) + 6) = w
    Application.ScreenUpdating = 1
    MsgBox "işlem tamam." & vbLf & CDate(TimeValue(Now) - t), vbInformation
End Sub



Private Sub Worksheet_Activate()
    yol = ThisWorkbook.Path & "\Rapor\"
    dosya = Dir(yol, vbDirectory)
    Dim b()
        Do While dosya <> ""
            If dosya <> "." And dosya <> ".." Then
                If (GetAttr(yol & dosya) And vbDirectory) = vbDirectory Then
                    say = say + 1
                    ReDim Preserve b(1 To say)
                    b(say) = dosya
                    ay = ay & dosya & ","
                End If
            End If
            dosya = Dir
        Loop
  If ay <> "" Then
    [E2].Validation.Delete
    [E2].Validation.Add xlValidateList, Formula1:=Left(ay, Len(ay) - 1)
  End If
End Sub
Kullanıcı avatarı
gicimi
Yeni Başlamış
 
Kayıt: 28 Arl 2014 02:06
Meslek: teknisyen
Yaş: 32
İleti: 55
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: ankara

Önceki

Forum Excel Okulu ile ilgili Soru ve Cevap Alanı

Online Kullanıcılar

Bu forumu görüntüleyenler: Kayıtlı kullanıcı yok ve 1 misafir

Bumerang - Yazarkafe