DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Option Explicit
Sub AKTAR()
Dim K1 As Workbook, K2 As Workbook, S1 As Worksheet
Dim FSO As Object, Yol As String
Dim Dosya As Variant, X As Long, Y As Integer
Dim Veri_Dosyası As Workbook, Sayfa As Worksheet
Application.ScreenUpdating = False
Set K1 = ThisWorkbook
Set S1 = K1.Sheets("Aktar")
Yol = K1.Path & "\DAĞIT"
On Error Resume Next
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.CreateFolder Yol
On Error GoTo 0
Dosya = Application.GetOpenFilename("Excel Dosyaları (*.xl*),*.xl*,", 3, "Lütfen dosya seçiniz...", MultiSelect:=True)
If Not IsArray(Dosya) Then
MsgBox "Dosya seçimi yapmadığınız için işleminiz iptal edilmiştir !", vbExclamation
Exit Sub
End If
For X = 11 To S1.Cells(Rows.Count, 1).End(3).Row
If S1.Cells(X, 1) <> "" Then
Set K2 = Workbooks.Add(1)
For Y = LBound(Dosya) To UBound(Dosya)
DoEvents
Application.DisplayAlerts = False
Set Veri_Dosyası = Workbooks.Open(Dosya(Y), False, False)
Application.DisplayAlerts = True
For Each Sayfa In Veri_Dosyası.Worksheets
If WorksheetFunction.CountIf(S1.Range("B" & X & ":AL" & X), Sayfa.Name) > 0 Then
Sayfa.Copy After:=K2.Sheets(K2.Worksheets.Count)
End If
Next
Veri_Dosyası.Close 0
Next
Application.DisplayAlerts = False
If K2.Worksheets.Count > 1 Then
K2.Sheets(1).Delete
K2.SaveAs Yol & "\" & S1.Cells(X, 1) & ".xls"
K2.Close 0
End If
Application.DisplayAlerts = True
End If
Next
Set K1 = Nothing
Set S1 = Nothing
Set FSO = Nothing
Set K2 = Nothing
Set Veri_Dosyası = Nothing
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End SubOption Explicit
Sub AKTAR()
Dim K1 As Workbook, K2 As Workbook, S1 As Worksheet
Dim FSO As Object, Yol As String, Klasor As Object
Dim Dosya As Object, X As Long, Bul As Range
Dim Veri_Dosyası As Workbook, Sayfa As Worksheet
Dim Dosya_Kaydetme_Formati As Integer, No As Integer
Set Klasor = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçiniz !", 1)
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.GetFolder(Klasor.Items.Item.Path).Files.Count = 0 Then
MsgBox "Seçtiğiniz klasörde dosya bulunamadı !", vbCritical
Exit Sub
End If
Application.ScreenUpdating = False
Dosya_Kaydetme_Formati = Application.DefaultSaveFormat
Set K1 = ThisWorkbook
Set S1 = K1.Sheets("Aktar")
Yol = K1.Path & "\DAĞIT"
If Val(Application.Version) < 12 Then
Application.DefaultSaveFormat = -4143
No = -4143
Else
Application.DefaultSaveFormat = 56
No = 56
K1.CheckCompatibility = False
End If
On Error Resume Next
FSO.CreateFolder Yol
On Error GoTo 0
For X = 11 To S1.Cells(Rows.Count, 1).End(3).Row
If S1.Cells(X, 1) <> "" Then
Set K2 = Workbooks.Add(1)
For Each Dosya In FSO.GetFolder(Klasor.Items.Item.Path).Files
DoEvents
Application.DisplayAlerts = False
Set Veri_Dosyası = Workbooks.Open(Dosya, False, False)
Application.DisplayAlerts = True
For Each Sayfa In Veri_Dosyası.Worksheets
Set Bul = S1.Range("B" & X & ":AL" & X).Find(CStr(Sayfa.Name), , , xlWhole)
If Not Bul Is Nothing Then
Sayfa.Copy After:=K2.Sheets(K2.Worksheets.Count)
End If
Next
Veri_Dosyası.Close 0
Next
Application.DisplayAlerts = False
If K2.Worksheets.Count > 1 Then
K2.Sheets(1).Delete
K2.SaveAs Yol & "\" & S1.Cells(X, 1) & ".xls", No
K2.Close 0
End If
Application.DisplayAlerts = True
End If
Next
Application.DefaultSaveFormat = Dosya_Kaydetme_Formati
Set K1 = Nothing
Set S1 = Nothing
Set FSO = Nothing
Set K2 = Nothing
Set Veri_Dosyası = Nothing
Set Bul = Nothing
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub