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

Aksuda

Altın Üye
Katılım
14 Nisan 2019
Mesajlar
40
Excel Vers. ve Dili
Excel 2010 ve üzeri. İngilizce
Merhaba,


Çok çok yeni bir üyeyim. Uzun yıllardır makro kullanmıyorum, pek çok şeyi unutmuşum :( Siz üstadlardan yardım rica ediyorum.

Bir "Marka" dosyam var. Bu dosya içerisinde 300 tane sheet var. Her sheetin içerisindeki verilerin kopyalanması gereken 300 dosya var.
Her bir sheet in tek tek ana dosyasına kopyalanması gerekiyor.

Ben bir makro hazırladım ama sadece bir sheeti yapıyor diğer sheetleri yaptırmakla ilgili bir türlü çözüm bulamadım.


Bir soru: Hangi sheet hangi dosyayı açması gerekiyor gibi bir liste ile çalıştırmak daha mı mantıklı olur ben bilemedim, mümkün mü? Nasıl yapabilirim.?

1 haftadır çözmeye çalışıyorum, dün gece 3 e kadar uğraştım ama ne yapsam olmadı. Döngü kurmak istedim ama oda olmadı bu kadar yapabildim.


Engin bilginizle yardımlarınızı rica ediyorum.

Çok teşekkür ederim.


Dosyalarım aşağıdaki linktedir. Teşekkürler

https://www.dosyaupload.com/6d2b
https://www.dosyaupload.com/6d2c
https://www.dosyaupload.com/6d2d
https://www.dosyaupload.com/6d2e


Kod:
Sub COPY()

'Marka dosyasındaki her sheet için ayrı ayrı dosyalar açılarak copy işlemi gerçekleşecek
    ' Ben sadece tek bir sheet için yapabiliyorum. 300 sheet ve 300 dosya için bu kodun çalışması gerekiyor.
        ' Daha kısa bir yolu var mı?


Worksheets("AGRI KESICI").Select
Range("A2:AZ2").Select

Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.COPY

Workbooks.Open Filename:="D:\makrolar\excelweb\XAGRI KESICI.xlsx"
Worksheets("YENI").Select
Range("B:B").End(xlDown).Offset(1, 0).Select 'Son satıra git
ActiveCell.End(xlToLeft).Select 'son satıın en soluna gider
ActiveSheet.Paste 'Yapıştır
ActiveWorkbook.Save
'ActiveWorkbook.Close


Worksheets("COCUK").Select
Range("A2:AZ2").Select

Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.COPY

Workbooks.Open Filename:="D:\makrolar\excelweb\excelweb\XCOCUK.xlsx"
Worksheets("YENI").Select
Range("B:B").End(xlDown).Offset(1, 0).Select 'Son satıra git
ActiveCell.End(xlToLeft).Select 'son satıın en soluna gider
ActiveSheet.Paste 'Yapıştır
ActiveWorkbook.Save


End Sub
 
Son düzenleme:
Katılım
5 Kasım 2006
Mesajlar
571
Excel Vers. ve Dili
TÜRKCE Excel 2021 32bit
Merhaba.
Örnek dosyayı harici siteye yüklerseniz yapabilirim.
Kodlardan anladığım döngü ile dosya içinde excel dosyaları bulunacak ve döngü ile açılıp ilgili yerlere kopyalanıp kapatılacak.Tabi bu yöntemin yavaş çalışacağını sanıyorum aç kapat ile.Belki Ado ile açtırmadanda halledilebilir.
 

Aksuda

Altın Üye
Katılım
14 Nisan 2019
Mesajlar
40
Excel Vers. ve Dili
Excel 2010 ve üzeri. İngilizce
Merhaba.
Örnek dosyayı harici siteye yüklerseniz yapabilirim.
Kodlardan anladığım döngü ile dosya içinde excel dosyaları bulunacak ve döngü ile açılıp ilgili yerlere kopyalanıp kapatılacak.Tabi bu yöntemin yavaş çalışacağını sanıyorum aç kapat ile.Belki Ado ile açtırmadanda halledilebilir.
Dönüşünüz için teşekkür ederim.
Maalesef dosya yükleyemiyorum Altın üyeliğimin aktivasyonunu bekliyorum. Başka bir şekilde size nasıl iletebilirim?
 

Aksuda

Altın Üye
Katılım
14 Nisan 2019
Mesajlar
40
Excel Vers. ve Dili
Excel 2010 ve üzeri. İngilizce
Sonunda dosyaları ekleyebildim, sizden ricam inceleyip dönüş yapabilir misiniz?

Teşekkür ederim.
 

Ekli dosyalar

Katılım
5 Kasım 2006
Mesajlar
571
Excel Vers. ve Dili
TÜRKCE Excel 2021 32bit
Ben kendi adıma öğleden sonra bakabilirim abey.
 

yanginci34

Altın Üye
Katılım
6 Temmuz 2010
Mesajlar
1,587
Excel Vers. ve Dili
excel2016
Merhaba. Kodunuzu aşağıdaki gibi değiştirip denermisiniz.
Kod:
Sub COPY()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Marka dosyasındaki her sheet için ayrı ayrı dosyalar açılarak copy işlemi gerçekleşecek
    ' Ben sadece tek bir sheet için yapabiliyorum. 300 sheet ve 300 dosya için bu kodun çalışması gerekiyor.
        ' Daha kısa bir yolu var mı?
        Dim i
        Dim a
For i = 2 To Sheets.Count
Set a = Sheets(i)

a.Select
a.Range("r1") = a.Name
Range("A2:AZ2").Select
Set isim = a.Range("r1")
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.COPY

Workbooks.Open Filename:="D:\makrolar\excelweb\" & "X" & isim & ".xlsx"
Worksheets("YENI").Select
Range("B:B").End(xlDown).Offset(1, 0).Select 'Son satıra git
ActiveCell.End(xlToLeft).Select 'son satıın en soluna gider
ActiveSheet.Paste 'Yapıştır
ActiveWorkbook.Save
'ActiveWorkbook.Close

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub
 

Aksuda

Altın Üye
Katılım
14 Nisan 2019
Mesajlar
40
Excel Vers. ve Dili
Excel 2010 ve üzeri. İngilizce
Sayın @yanginci34

Dönüşünüz için teşekkür ederim.


Denedim fakat aşağıdaki hatayı verdi.



1555326699246.png
 
Son düzenleme:
Katılım
5 Kasım 2006
Mesajlar
571
Excel Vers. ve Dili
TÜRKCE Excel 2021 32bit
Dosyaları bir klasör içine attım.
Siz koddaki yolu D sürücüsüne göre ayarlarsınız.
Kod çalışması uzun sürerse bakarız.Kusura bakmayın daha yeni müsait oldum.

https://dosya.co/8erv1ptlfvvz/Neuer_Ordner.rar.html

PHP:
Sub COPY()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Marka dosyasindaki her sheet için ayri ayri dosyalar açilarak copy islemi gerçeklesecek
    ' Ben sadece tek bir sheet için yapabiliyorum. 300 sheet ve 300 dosya için bu kodun çalismasi gerekiyor.
        ' Daha kisa bir yolu var mi?
        Dim i, ac As Workbook

For i = 1 To Sheets.Count
    ThisWorkbook.Sheets(i).Select
    ThisWorkbook.Sheets(i).Range("A2").Select
    ThisWorkbook.Sheets(i).Range(Selection, Selection.End(xlToRight)).Select
    ThisWorkbook.Sheets(i).Range(Selection, Selection.End(xlDown)).Select
    Selection.COPY
    Set ac = Workbooks.Open(ThisWorkbook.Path & "\" & "X" & ThisWorkbook.Sheets(i).Name & ".xlsx")
    ac.Worksheets("YENI").Select
    ac.Worksheets("YENI").Range("A" & ac.Worksheets("YENI").Cells(Rows.Count, 1).End(3).Row + 1).Select 'Son satira git
    ac.ActiveSheet.Paste 'Yapistir
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    Set ac = Nothing
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Bitti"
End Sub
 
Katılım
5 Kasım 2006
Mesajlar
571
Excel Vers. ve Dili
TÜRKCE Excel 2021 32bit
Aslında safa adı ile eşleşme olmuyorsa hata veriyor onada bir koşul ekleyeyim.
 
Katılım
5 Kasım 2006
Mesajlar
571
Excel Vers. ve Dili
TÜRKCE Excel 2021 32bit
Dosyaları bir klasör içine attım.
Siz koddaki yolu D sürücüsüne göre ayarlarsınız.
Kod çalışması uzun sürerse bakarız.Kusura bakmayın daha yeni müsait oldum.

https://dosya.co/8erv1ptlfvvz/Neuer_Ordner.rar.html

PHP:
Sub COPY()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Marka dosyasindaki her sheet için ayri ayri dosyalar açilarak copy islemi gerçeklesecek
    ' Ben sadece tek bir sheet için yapabiliyorum. 300 sheet ve 300 dosya için bu kodun çalismasi gerekiyor.
        ' Daha kisa bir yolu var mi?
        Dim i, ac As Workbook

For i = 1 To Sheets.Count
    ThisWorkbook.Sheets(i).Select
    ThisWorkbook.Sheets(i).Range("A2").Select
    ThisWorkbook.Sheets(i).Range(Selection, Selection.End(xlToRight)).Select
    ThisWorkbook.Sheets(i).Range(Selection, Selection.End(xlDown)).Select
    Selection.COPY
    Set ac = Workbooks.Open(ThisWorkbook.Path & "\" & "X" & ThisWorkbook.Sheets(i).Name & ".xlsx")
    ac.Worksheets("YENI").Select
    ac.Worksheets("YENI").Range("A" & ac.Worksheets("YENI").Cells(Rows.Count, 1).End(3).Row + 1).Select 'Son satira git
    ac.ActiveSheet.Paste 'Yapistir
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    Set ac = Nothing
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Bitti"
End Sub
Kodu alttaki gibi değiştirin.

Rich (BB code):
Sub COPY()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Marka dosyasindaki her sheet için ayri ayri dosyalar açilarak copy islemi gerçeklesecek
    ' Ben sadece tek bir sheet için yapabiliyorum. 300 sheet ve 300 dosya için bu kodun çalismasi gerekiyor.
        ' Daha kisa bir yolu var mi?
        Dim i, ac As Workbook

For i = 1 To Sheets.Count

If Dir(ThisWorkbook.Path & "\" & "X" & ThisWorkbook.Sheets(i).Name & ".xlsx") <> "" Then

    ThisWorkbook.Sheets(i).Select
    ThisWorkbook.Sheets(i).Range("A2").Select
    ThisWorkbook.Sheets(i).Range(Selection, Selection.End(xlToRight)).Select
    ThisWorkbook.Sheets(i).Range(Selection, Selection.End(xlDown)).Select
    Selection.COPY

    Set ac = Workbooks.Open(ThisWorkbook.Path & "\" & "X" & ThisWorkbook.Sheets(i).Name & ".xlsx")
    ac.Worksheets("YENI").Select
    ac.Worksheets("YENI").Range("A" & ac.Worksheets("YENI").Cells(Rows.Count, 1).End(3).Row + 1).Select 'Son satira git
    ac.ActiveSheet.Paste 'Yapistir
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    Set ac = Nothing
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Bitti"
End Sub
 

Aksuda

Altın Üye
Katılım
14 Nisan 2019
Mesajlar
40
Excel Vers. ve Dili
Excel 2010 ve üzeri. İngilizce
Gönderimi okuyunca eksik bilgi verdiğimi farkettim. Çok çok özür. :(


Marka dosyasının içerisindeki 300 sheet'in her biri için ayrı ayrı bu işlemin yapılması gerekiyor.

Örnek1:
@ Marka dosyasında "AGRI KESICI" sheeti için: Sheet ((((dolu)))) ise 2. satır itibariyle dolu olan tüm satırları "XAGRI KESICI.xlsx" dosyasına kopyalayacak bir makro.

Örnek2:
@ Marka dosyasında "COCUK" sheeti için: Sheet ((((dolu)))) ise 2. satır itibariyle dolu olan tüm satırları "XCOCUK.xlsx" dosyasına kopyalayacak bir makro.

Not: Sheet ile kopyalama yapılacak dosya isimleri "birebir" aynı değildir. Ben buraya örnek olsun diye sadece bu isimlerde hazırladım.

@@ Bu iş her ay "tek tek" 300 sheet ve dosya için 10-15 defa yapılıyor. Bu 4500 defa dosya açıp kapatmak anlamına geliyor. :(

@@@ Benim "Marka.xlsb" dosyasına hazırladığım makro aslında çalışıyor ama sadece "yolunu adresini belirttiğim" 1 sheet için çalışıyor. Diğer sheetler için döngü kurmak istedim ama bir türlü beceremedim.

Bu şekilde tekrar değerlendirmenize sunuyorum. Ne yazık ki ben beceremedim.

Tekrar teşekkür ederim
 

Ekli dosyalar

Son düzenleme:
Katılım
5 Kasım 2006
Mesajlar
571
Excel Vers. ve Dili
TÜRKCE Excel 2021 32bit
Kodu alttaki gibi ayarlamıştım.
Yarın akşama birde Ado ile denerim olmazsa.
Altın Üye olmadığım için eski dosyaya göre kodlar.

Rich (BB code):
Sub COPY()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Marka dosyasindaki her sheet için ayri ayri dosyalar açilarak copy islemi gerçeklesecek
    ' Ben sadece tek bir sheet için yapabiliyorum. 300 sheet ve 300 dosya için bu kodun çalismasi gerekiyor.
        ' Daha kisa bir yolu var mi?
        Dim i, ac As Workbook

For i = 1 To Sheets.Count

If Dir(ThisWorkbook.Path & "\" & "X" & ThisWorkbook.Sheets(i).Name & ".xlsx") <> "" Then
If Range("A2").Value <> "" Then
    Range("A2", Range("A2").End(xlDown).End(xlToRight)).COPY

    Set ac = Workbooks.Open(ThisWorkbook.Path & "\" & "X" & ThisWorkbook.Sheets(i).Name & ".xlsx")
    ac.Worksheets("YENI").Select
    ac.Worksheets("YENI").Range("A" & ac.Worksheets("YENI").Cells(Rows.Count, 1).End(3).Row + 1).Select 'Son satira git
    ac.ActiveSheet.Paste 'Yapistir
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    Set ac = Nothing
End If
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.CutCopyMode = False
MsgBox "Bitti"
End Sub
 

Aksuda

Altın Üye
Katılım
14 Nisan 2019
Mesajlar
40
Excel Vers. ve Dili
Excel 2010 ve üzeri. İngilizce
Kodu alttaki gibi değiştirin.

Rich (BB code):
Sub COPY()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Marka dosyasindaki her sheet için ayri ayri dosyalar açilarak copy islemi gerçeklesecek
    ' Ben sadece tek bir sheet için yapabiliyorum. 300 sheet ve 300 dosya için bu kodun çalismasi gerekiyor.
        ' Daha kisa bir yolu var mi?
        Dim i, ac As Workbook

For i = 1 To Sheets.Count

If Dir(ThisWorkbook.Path & "\" & "X" & ThisWorkbook.Sheets(i).Name & ".xlsx") <> "" Then

    ThisWorkbook.Sheets(i).Select
    ThisWorkbook.Sheets(i).Range("A2").Select
    ThisWorkbook.Sheets(i).Range(Selection, Selection.End(xlToRight)).Select
    ThisWorkbook.Sheets(i).Range(Selection, Selection.End(xlDown)).Select
    Selection.COPY

    Set ac = Workbooks.Open(ThisWorkbook.Path & "\" & "X" & ThisWorkbook.Sheets(i).Name & ".xlsx")
    ac.Worksheets("YENI").Select
    ac.Worksheets("YENI").Range("A" & ac.Worksheets("YENI").Cells(Rows.Count, 1).End(3).Row + 1).Select 'Son satira git
    ac.ActiveSheet.Paste 'Yapistir
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    Set ac = Nothing
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Bitti"
End Sub

Bilginize ve Ellerinize sağlık. Sizi yordum gerçekten kusuruma bakmayın. Sorunumu eksik iletimişim. :(
Tekrar bakabilmeniz mümkün olabilir mi?
Teşekkür Ederim.
 
Katılım
5 Kasım 2006
Mesajlar
571
Excel Vers. ve Dili
TÜRKCE Excel 2021 32bit
Bilginize ve Ellerinize sağlık. Sizi yordum gerçekten kusuruma bakmayın. Sorunumu eksik iletimişim. :(
Tekrar bakabilmeniz mümkün olabilir mi?
Teşekkür Ederim.
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.
 
Katılım
5 Kasım 2006
Mesajlar
571
Excel Vers. ve Dili
TÜRKCE Excel 2021 32bit
Önceki yolladığım dosyada alttaki kodları bir deneyin.
Belki tam çalışmayabilir.


Rich (BB code):
Sub COPY()

Dim con As Object, rs As Object, sorgu As String, ii As Integer, i As Integer
Set con = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
Application.ScreenUpdating = False
On Error Resume Next
For ii = 1 To Sheets.Count
If Dir(ThisWorkbook.Path & "\" & "X" & ThisWorkbook.Sheets(ii).Name & ".xlsx") <> "" Then
If Range("A2").Value <> "" Then

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.Path & "\" & "X" & ThisWorkbook.Sheets(ii).Name & ".xlsx" & ";extended properties=""Excel 12.0;hdr=no"""

sorgu = "select * from [YENI$]"
rs.Open sorgu, con, 1, 3


Application.ScreenUpdating = False
    If Not rs.EOF Then
        For i = 2 To Cells(Rows.Count, 1).End(3).Row
            rs.addnew
            rs(0).Value = Cells(i, 1).Value
            rs(1).Value = Cells(i, 2).Value
            rs(2).Value = Cells(i, 3).Value
            rs(3).Value = Cells(i, 4).Value
            rs(4).Value = Cells(i, 5).Value
            rs.Update
        Next
    End If

con.Close
End If
End If
Next
Set rs = Nothing: Set con = Nothing: sorgu = vbNullString

Application.ScreenUpdating = True

MsgBox "Bitti"
End Sub
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,758
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Merhaba Sayın FERAZ'ın koduna küçük ilaveler yaptım

Kod:
Sub COPY()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim i, ac As Workbook
For i = 1 To ThisWorkbook.Sheets.Count
If Dir(ThisWorkbook.Path & "\" & "X" & ThisWorkbook.Sheets(i).Name & ".xlsx") <> "" Then
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(ThisWorkbook.Path & "\" & "X" & ThisWorkbook.Sheets(i).Name & ".xlsx")
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
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.CutCopyMode = False
MsgBox "Bitti"
End Sub
 

Aksuda

Altın Üye
Katılım
14 Nisan 2019
Mesajlar
40
Excel Vers. ve Dili
Excel 2010 ve üzeri. İngilizce
Merhaba Sayın FERAZ'ın koduna küçük ilaveler yaptım

Kod:
Sub COPY()

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim i, ac As Workbook
For i = 1 To ThisWorkbook.Sheets.Count
If Dir(ThisWorkbook.Path & "\" & "X" & ThisWorkbook.Sheets(i).Name & ".xlsx") <> "" Then
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(ThisWorkbook.Path & "\" & "X" & ThisWorkbook.Sheets(i).Name & ".xlsx")
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
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.CutCopyMode = False
MsgBox "Bitti"
End Sub
Sayın @halit3

Emeğinize sağlık ama kod çalışmıyor. Bitti majo geliyor fakat hiçbir kopyalama işlemi yapmıyor.

Teşekkür ederim
 
Üst