DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Dim dosya_adı As String
Dim sat As String
Private Sub CommandButton1_Click()
dosya_adı = ActiveWorkbook.Name
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.Items.Item.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
On Error Resume Next
dosya_adı = ActiveWorkbook.Name
Dim wb As Workbook
Application.ScreenUpdating = False
For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).Files
For i = Len(Dosya.Name) To 1 Step -1
If Mid(Dosya.Name, i, 1) = "." Then
Dosya_adi = Mid(Dosya.Name, 1, i - 1)
Exit For
End If
Next
If ThisWorkbook.Name <> Dosya.Name Then
For j = 1 To 8
If Controls("TextBox" & j).Text = Dosya_adi Then
Set wb = Workbooks.Open(Kaynak & "\" & Dir(Dosya))
Range("A2:S1000").Copy
Windows(dosya_adı).Activate
sat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
Range("A" & sat).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
wb.Close False
Dosya = Dir
Exit For
End If
Next j
End If
Next
Range("A1").Select
MsgBox "işlem tamam"
Application.ScreenUpdating = True
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Set Obj = Nothing
Set Klasor = Nothing
End SubDim Klasor As Object
Dim Kaynak As String
Dim Uzanti As String
Dim dosya_adı As String
Dim Sayfa_Adı As String
Dim sat As String
Private Sub CommandButton1_Click()
a = MsgBox("Klasörün içindeki dosyalardan veri almak istiyormusunuz.?", vbYesNo + vbInformation, " uyarı")
If a = vbNo Then
Exit Sub
End If
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
On Error Resume Next
Kaynak = Klasor.SELF.Path
For i = Len(ThisWorkbook.Name) To 1 Step -1
If Mid(ThisWorkbook.Name, i, 1) = "." Then
Uzanti = Mid(ThisWorkbook.Name, i, Len(ThisWorkbook.Name))
End If
Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
sat = 2
Cells.ClearContents
dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name
Call Liste(Kaynak, Uzanti)
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Range("A1").Select
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste(Klasor As String, Uzanti As String)
Dim fL As Object, f As Object, Dosya As String
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).SubFolders
Dim wb As Workbook
Dosya = Dir(Klasor & "\*" & Uzanti)
While Dosya <> ""
DoEvents
If ThisWorkbook.Name <> Dosya Then
For i = Len(Dosya) To 1 Step -1
If Mid(Dosya, i, 1) = "." Then
Dosya_adi2 = Mid(Dosya, 1, i - 1)
Exit For
End If
Next
For j = 1 To 8
If Controls("TextBox" & j).Text = Dosya_adi2 Then
Set wb = Workbooks.Open(Klasor & "\" & Dosya)
Range("A2:S1000").Copy
Windows(dosya_adı).Activate
Range("A" & sat).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
wb.Close False
sat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
Exit For
End If
Next j
End If
Dosya = Dir
Wend
On Error GoTo sonraki
For Each f In fL
Kaynak = f.Path
Call Liste(Kaynak, "")
sonraki:
Next
Set fL = Nothing
End Sub