makro düzenleme

[igultekin2000]

kullanmakta olduğum işlemin daha kullanışlı olması için bir düzenleme olur mu diye düşünüyorum. işlemde kullanılan makro ekteki gibidir.

Dim hedefklasor, hedefdosya, dosyaadi As String
Dim kackelime, ensonsatir, ensonsutun, satir As Long
Dim firmaadi, arauzanti, uzanti, aradizin As String
Dim aranacaklar(1000) As String

Sub menu()
    satir = 1
    aradizin = Cells(2, 1).Value & "\"
    firmaadi = Cells(2, 2).Value
    arauzanti = Cells(2, 3).Value
    
    hedefklasor = "C:\TUMDOSYALAR\" & firmaadi
    klasorolustur ("C:\TUMDOSYALAR\" & firmaadi)
    
    Call dosyalaribul
    MsgBox ("Dosyaları toplama işlemi tamamlandı.")
End Sub

Sub sonsatirne()
  If WorksheetFunction.CountA(Cells) > 0 Then
     ensonsatir = Cells.Find(what:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
     ensonsutun = Cells.Find(what:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
  Else
     ensonsatir = Rows.Count
     ensonsutun = Columns.Count
  End If
  
End Sub

Sub dosyalaribul()
    Dim FileNameWithPath As Variant
    Dim ListOfFilenamesWithParh As New Collection
    Call FileSearchByHavrda(ListOfFilenamesWithParh, aradizin, arauzanti, True)
    
    Dim z As Long
    Dim ws As Worksheet
    Application.ScreenUpdating = False

    For Each FileNameWithPath In ListOfFilenamesWithParh
        dosyaadi = FileNameWithPath
        uzanti = Right(dosyaadi, Len(dosyaadi) - InStrRev(dosyaadi, "."))
        dosyagecici = dosyaadi
        birbuldu = False
        ikibuldu = False
        firmaklasor = ""
        For i = Len(dosyagecici) To 1 Step -1
            If Mid(dosyaadi, i, 1) = "\" And birbuldu = False Then
               hedefdosya = Mid(dosyagecici, i + 1, Len(dosyagecici))
               dosyagecici = Mid(dosyagecici, 1, i - 1)
               birbuldu = True
               i = Len(dosyagecici)
            End If
            If Mid(dosyaadi, i, 1) = "\" And ikibuldu = False Then
               firmaklasor = Mid(dosyagecici, i + 1, Len(dosyagecici))
               Exit For
            End If
        Next i
        
        If firmaklasor = firmaadi Then
         a = a
         FileCopy dosyaadi, hedefklasor & "\" & hedefdosya
        End If
        
    Next FileNameWithPath

    If ListOfFilenamesWithParh.Count = 0 Then
        Debug.Print "Dosya bulunamadı."
        MsgBox "Dosya bulunamadı."
    End If

    Application.ScreenUpdating = True
    Exit Sub


End Sub

Private Sub FileSearchByHavrda(pFoundFiles As Collection, pPath As String, pMask, pIncludeSubdirectories As Boolean)
  Dim DirFile As String
    Dim CollectionItem As Variant
    Dim SubDirCollection As New Collection

    pPath = Trim(pPath)
    If Right(pPath, 1) <> "\" Then pPath = pPath & "\"
    
    DirFile = Dir(pPath & pMask)
    Do While DirFile <> ""
    pFoundFiles.Add pPath & DirFile
    DirFile = Dir
    Loop

    If Not pIncludeSubdirectories Then Exit Sub

    DirFile = Dir(pPath & "*", vbDirectory)
    Do While DirFile <> ""
        If DirFile <> "." And DirFile <> ".." Then If ((GetAttr(pPath & DirFile) And vbDirectory) = 16) Then SubDirCollection.Add pPath & DirFile
        DirFile = Dir
    Loop

    For Each CollectionItem In SubDirCollection
         Call FileSearchByHavrda(pFoundFiles, CStr(CollectionItem), pMask, pIncludeSubdirectories) ' Recursive procedure call
    Next

End Sub

Sub klasorolustur(strPath As String)
    Dim elm As Variant
    Dim strCheckPath As String

    strCheckPath = ""
    For Each elm In Split(strPath, "\")
        strCheckPath = strCheckPath & elm & "\"
        If Len(Dir(strCheckPath, vbDirectory)) = 0 Then MkDir strCheckPath
    Next
End Sub