Sayfa adına göre dosya açsın ve kopyalasın

[Aksuda]

Rica ederim üstadım.Bende açıkçası acemiyim lakin zamanında başımdan geçmişti benzer örnekler
Dosya aynı ise yarın akşam gibi Ado ile denerim.Önceden dediğim gibi dosyayı indiremiyorum üyelikten dolayı.
Aslında birkaç satır kod değişecek tahminen Ado ile tabii olurmu olmazmı bilemiyorum.

Sayın @FERAZ

Ben size dosyaları dosya upload ile gönderebilirim. Diğer kodları da denedim olmadı. Ado ile çözümünüzü merak ediyorum.

@ bu sheet şu dizinde şu dosyaya kopya diyebileceğim bir dil bulamadım. Acaba dosyaların olduğu klasörleri ve dosyaları bir liste haline getirsem ve o şekilde çağırarak yapmak istesem olur mu?

 

[halit3]

14 nolu mesajdaki dosyaların hepsini aynı klasöre koyun ve kodu çalıştırın kodlar bende çalıştı

 

[FERAZ]

Kodların hepsi çalışıyor benimki.Halit hocamızınkıde çalışıyor diyorsa çalışıyor deneyemedim.
Dosyaların hepsini bir klasöre atıp sonra rar yada zip olarak sıkıştırırsanız hepsini ayrı ayrı yüklemek zorunda kalmazsınız.
Bu arada Ao ile kodlarıda eklemiştim ve çalışıyordu bende.Makronun çalıştığı dosyadaki sayfalar ile diğer excellerin adı tutuyorsa çalışmaması için bir neden yok.

 

[Aksuda]

14 nolu mesajdaki dosyaların hepsini aynı klasöre koyun ve kodu çalıştırın kodlar sende çalıştı

Halit3 aslında hepsi aynı klasörde hocam ama sanırım ben bi hata yaptım, tekrar deneyeceğim çok teşekkür ederim.

 

[Aksuda]

Merhaba,

Özür dilerim ben anlatamadım.
14 nolu mesajımda dosyaların sheetler ve dosyaların isimlerinin uyumsuz yani farklı olduğundan bahsetmiştim. Bu yüzden bir türlü yapamadım

Emeğiniz ve paylaşımlarınız için tekrar tekrar teşekkür ederim.

 

[halit3]

Birde bu kodu dene

Sub COPY()


Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Worksheets(ActiveSheet.Name).Cells(1, 5).Value = "OK"

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")

For Each dosya In fL.GetFolder(Kaynak).Files

If ThisWorkbook.Name <> dosya.Name Then
veri = dosya

Dim i, ac As Workbook
For i = 1 To ThisWorkbook.Sheets.Count

If ThisWorkbook.Sheets(Sheets(i).Name).Range("A2").Value <> "" Then
ThisWorkbook.Sheets(Sheets(i).Name).Range("A2", ThisWorkbook.Sheets(Sheets(i).Name).Range("A2").End(xlDown).End(xlToRight)).COPY
Set ac = Workbooks.Open(veri)
son = ac.Worksheets(1).Cells(Rows.Count, "a").End(3).Row + 1
ac.Worksheets(1).Paste Destination:=ac.Worksheets(1).Cells(son, 1)
ac.Save
ac.Close
Set ac = Nothing
End If
Next
'If fL.GetExtensionName(Dosya) = "JPG" Then
End If
Next


Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.CutCopyMode = False


Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If


MsgBox "Bitti"
End Sub

 

[halit3]

Birde bu kodu deneyiniz yukarıdaki mesajdan birazcık farklı

Sub COPY()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Application.ScreenUpdating = False
Application.DisplayAlerts = False


For Each dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).Files
If ThisWorkbook.Name <> dosya.Name Then

veri = dosya
Dim i, ac As Workbook
For i = 1 To ThisWorkbook.Sheets.Count

If ThisWorkbook.Sheets(Sheets(i).Name).Range("A2").Value <> "" Then
If InStr(Trim(dosya.Name), Sheets(i).Name) > 0 Then
ThisWorkbook.Sheets(Sheets(i).Name).Range("A2", ThisWorkbook.Sheets(Sheets(i).Name).Range("A2").End(xlDown).End(xlToRight)).COPY
Set ac = Workbooks.Open(veri)
son = ac.Worksheets(1).Cells(Rows.Count, "a").End(3).Row + 1
ac.Worksheets(1).Paste Destination:=ac.Worksheets(1).Cells(son, 1)
ac.Save
ac.Close
Set ac = Nothing
End If
End If
Next

End If
Next

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.CutCopyMode = False

Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If


End Sub

 

[Aksuda]

Çok ama çok teşekkür ederim. Bana öyle bir iyilik yaptınız ki. Kendi dosyama göre uyarladım, sorunsuz çalışıyor.

Sayın @halit3 ve @FERAZ
Bilginize, Emeğinize ve Gönlünüze Sağlık.

Sayenizde bazı şeyleri tekrar hatırladım tamamen unutmuştum

 

[halit3]

Teşekkürler iyi çalışmalar