makroda klasör belirleme

[igultekin2000]

iyi günler; kullanmakta olduğum makroda işlem yaparken klasör seçmem gerekiyor. bazen sabit bilgisayarda da kullanıyorum. ilgili klasör " D:\Stok " olarak sabitlemek istiyorum. makroda nasıl bir düzenleme yapmam gerekiyor.

Sub numan()
 Dim Klasör As Object, Veri_Dosyası As Workbook, SR As Worksheet, Dosya_Yolu As String
    Dim satır As Long, Dosya As Object, Kaynak_Dosya As Object, SAYFA, SAYFA1 As Worksheet
    On Error GoTo Son
    Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 1)
    If Klasör Is Nothing Then
        MsgBox "Klasör seçimi yapmadığınız için işlemini iptal edilmiştir.", vbCritical
        Exit Sub
    End If
    Range("C3:E" & Rows.Count).NumberFormat = "#,##0.00"
    Range("A3:E" & Rows.Count).ClearContents
    Application.ScreenUpdating = False
    Set Veri_Dosyası = ThisWorkbook
    Set SR = Veri_Dosyası.Sheets("Sayfa1")
    Dosya_Yolu = Klasör.Items.Item.Path
    If CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files.Count = 0 Then GoTo Son
    For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
    
     If Dosya.Name = "KUMAS.xlsx" Then
            Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)
 'Set SAYFA1 = Kaynak_Dosya.Sheets("StokRapor")
 For Each SAYFA1 In Kaynak_Dosya.Worksheets
        satır1 = 3
       For x = 4 To SAYFA1.[B65536].End(3).Row
            SR.Range("A" & satır1) = SAYFA1.Range("B" & x)
            SR.Range("C" & satır1) = SAYFA1.Range("C" & x)
            SR.Range("D" & satır1) = SAYFA1.Range("D" & x)
             SR.Range("E" & satır1) = SAYFA1.Range("E" & x)
            
            satır1 = satır1 + 1
         
            Next x
            Next
            Kaynak_Dosya.Close True
        End If
        If Dosya.Name = "EMTIA.xlsx" Then
            Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)
 'Set SAYFA = Kaynak_Dosya.Sheets("STOK_BAKIYE")
 For Each SAYFA In Kaynak_Dosya.Worksheets
            satır = 3
       For k = 3 To SAYFA.[B65536].End(3).Row
            SR.Range("AA" & satır) = SAYFA.Range("B" & k)
            SR.Range("AB" & satır) = SAYFA.Range("C" & k)
            SR.Range("AC" & satır) = SAYFA.Range("D" & k)
            SR.Range("AD" & satır) = SAYFA.Range("E" & k)
            SR.Range("AE" & satır) = SAYFA.Range("F" & k)
            satır = satır + 1
            Next k
            Next
            Kaynak_Dosya.Close True
        End If
        
      
    Next
Son = Range("AA" & Rows.Count).End(3).Row
Alan = "AA3:AF" & Son
Range(Alan).Copy
Range("A65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
 Range("AA3:AE" & Rows.Count).ClearContents
    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır.", , "numan Şamil" ', vbInformation
    Exit Sub
Son:
    Kaynak_Dosya.Close True
    Application.ScreenUpdating = True
    MsgBox "Dosya bulunamamıştır !", vbCritical, "Dikkat !"
End Sub

verilerin toplandığı Rapor sayfası C' de masaüstünde

 

[netcini]

Eğer sabit klasör kullanacaksanız. Bu kodlara ihtiyacınız olmayacaktır.
Satır başlarına tek tırnak ( ' ) koyarak pasif haline getirin. Eğer sabit klasör işleminden vazgeçerseniz sonra tekrar kullanırsınız.

Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 1)
    If Klasör Is Nothing Then
        MsgBox "Klasör seçimi yapmadığınız için işlemini iptal edilmiştir.", vbCritical
        Exit Sub
    End If

Sonra bu koduda tek tırnak ile pasif hale getirin.

Dosya_Yolu = Klasör.Items.Item.Path

Aşağıdaki kodu yazın.

Dosya_Yolu = "D:Stok\"

Sanırım bu şekilde çözülür sorununuz.

 

[igultekin2000]

sorun düzeldi

Eğer sabit klasör kullanacaksanız. Bu kodlara ihtiyacınız olmayacaktır.
Satır başlarına tek tırnak ( ' ) koyarak pasif haline getirin. Eğer sabit klasör işleminden vazgeçerseniz sonra tekrar kullanırsınız.

Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 1)
    If Klasör Is Nothing Then
        MsgBox "Klasör seçimi yapmadığınız için işlemini iptal edilmiştir.", vbCritical
        Exit Sub
    End If

Sonra bu koduda tek tırnak ile pasif hale getirin.

Dosya_Yolu = Klasör.Items.Item.Path

Aşağıdaki kodu yazın.

Dosya_Yolu = "D:Stok\"

Sanırım bu şekilde çözülür sorununuz.

bilgilendirdiğiniz için teşekkürler, sorunsuz çalışıyor

 

[netcini]

Rica ederim