Farklı xls dosyalarını tek bir shette alt alta birleştirme

E

eosen11

Katılım
19 Ağustos 2011
Mesajlar
6
Excel Vers. ve Dili
Excell 2007
Korhan Bey,
vermiş olduğunuz kodu bana lazım olan dosyalara bir türlü uyarlayamadım. Ekteki dosyalardan 2009 yılından buyana her gün için bir excel dosyası olacak şekilde kayd altına alınmış. Ben bu dosyalardaki verileri bir excel sayfasında alt alta yazdırmak istiyorum. Yardımcı olursanız sevinirim.
 
E

eseslican

Katılım
3 Eylül 2007
Mesajlar
26
Excel Vers. ve Dili
eseses
Korhan bey,

Yazmış olduğunuz kodla 4 adet excel dosyasını tek bir dosyada birleştiriyoruz buna ek olarak şöyle bir şey yapmak mümkün mü? İlk excele ait çalışma sayfasının başlıkları A2 satırlarına geliyor sonrasında diğer 3 excel dosyasının başlıkları gelmese veriler A6 hücresinden devam etse?

 
E

eseslican

Katılım
3 Eylül 2007
Mesajlar
26
Excel Vers. ve Dili
eseses
Korhan bey,

Yazmış olduğunuz kodla 4 adet excel dosyasını tek bir dosyada birleştiriyoruz buna ek olarak şöyle bir şey yapmak mümkün mü? İlk excele ait çalışma sayfasının başlıkları A2 satırlarına geliyor sonrasında diğer 3 excel dosyasının başlıkları gelmese veriler A6 hücresinden devam etse?






Korhan Ayhan' Alıntı:
Merhaba,

Aşağıdaki kodu boş bir excel kitabına uygulayın.

Kodu çalıştırdığınızda seçtiğiniz klasör altında yeni bir excel sayfası oluşturulur ve içine klasör altındaki dosyaların ilk sayfalarındaki veriler alt alta aktarılır.

Yeni excel dosyası "Dosya_gg_aa_yyyy_ss_dd_nn" ismi ile kayıt edilir. Kırmızı bölüm günün tarihi ve saatidir.

Kod: 
Option Explicit
 
Sub DOSYALARDAN_VERİ_AL()
    Dim K1 As Workbook, K2 As Workbook
    Dim K3 As Workbook, S1 As Worksheet
    Dim X As Integer, Satır As Integer, Son_Satır As Long
    Dim Klasör As Object, Kaynak_Klasör As String, Dosya As String
    
    Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Kaynak dosyaları içeren klasörü seçin", 50, &H0)
    
    If Klasör = "Masaüstü" Or Klasör = "Desktop" Then
        Kaynak_Klasör = Environ("UserProfile") & "\Desktop\"
    ElseIf Not Klasör Is Nothing Then
        Kaynak_Klasör = Klasör.Items.Item.Path
    Else
        MsgBox "İşleme devam edbilmek için klasör seçimi yapmalısınız !" & Chr(10) & _
        "İşleminiz iptal edilmiştir.", vbCritical
        Exit Sub
    End If
    
    On Error Resume Next
    
    Set K1 = ThisWorkbook
    Set K2 = Workbooks.Add(1)
    Dosya = Dir(Kaynak_Klasör & "\*.xls")
    Satır = 2
    
    Application.ScreenUpdating = False
    
    Do
        If Dosya <> "" And Dosya <> K1.Name And InStr(1, Dosya, "Dosya") = 0 Then
            DoEvents
            Application.DisplayAlerts = False
            Set K3 = Workbooks.Open(Kaynak_Klasör & "\" & Dosya, False, False)
            Application.DisplayAlerts = True
            Set S1 = K3.Sheets(1)
            
            Son_Satır = S1.Cells(Rows.Count, 1).End(3).Row
            S1.Range("A2:AA" & Son_Satır).Copy _
            K2.Sheets("Sayfa1").Range("A" & Satır)
            Satır = K2.Sheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row + 2
            
            K3.Close True
            Dosya = Dir
        Else
            Dosya = Dir
        End If
    Loop While Dosya <> ""
    
    K2.Sheets("Sayfa1").Cells.EntireColumn.AutoFit
[COLOR=blue]    K2.SaveAs (Kaynak_Klasör & "\Dosya_" & Format(Now, "dd_mm_yyyy_hh_mm_ss"))
[/COLOR]    K2.Close True
    
    Set K1 = Nothing
    Set K2 = Nothing
    Set K3 = Nothing
    
    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Genişletmek için tıkla ...
 
K

katip16487

Altın Üye
Katılım
28 Haziran 2007
Mesajlar
168
Excel Vers. ve Dili
OFFİCE 2016 (Türkçe)
Altın Üyelik Bitiş Tarihi
17-03-2025
(5) nolu mesajda belirtilen klasörüm sabit olacağı için browse butonu ile seçmek yerine kodun içeriğine klasör yolunu nasıl yerleştirebilirim.

Örneğin, benim birleştirme işlemi yapacağım klasörün yolu "D:\KASA\KASA" şeklinde....

Yardım için teşekkür ederim....
 
M

MCAPOWER

Katılım
26 Ocak 2009
Mesajlar
21
Excel Vers. ve Dili
uSA
Inbox altında oluşturulan klasördeki mailler

Hocam selamlar,

Eline ve emeğine sağlık, bu kodlar çok işime yaradı. Şöyle bir sorum var;
Ben tüm maillerin eklerini değil de bazı maillerin (Mehmet mailinden gelen) maillerin eklerini kaydedebilir miyim? Aksi taktirde tüm mailleri farklı klasöre kopyalayp sadece Mehmetten gelen mailleri Inbox'da bıraktığımda çalışıyor ve her seferinde eklerini istediğim mailleri başka klasöre taşımak sıkıntılı oluyor, bu bağlamda;
1. Mehmet'ten gelen maillerin eklerini dışarı al işlemi yapılabilir mi?
2. Inbox veya Personel folder altındaki bir klasördeki maillerin eklerini dışarı alabilir miyiz?

Şimdiden teşekkürler.


Korhan Ayhan' Alıntı:
Merhaba,

Aşağıdaki kodu boş bir excel kitabına uygulayın.

Kodu çalıştırdığınızda seçtiğiniz klasör altında yeni bir excel sayfası oluşturulur ve içine klasör altındaki dosyaların ilk sayfalarındaki veriler alt alta aktarılır.

Yeni excel dosyası "Dosya_gg_aa_yyyy_ss_dd_nn" ismi ile kayıt edilir. Kırmızı bölüm günün tarihi ve saatidir.

Kod: 
Option Explicit
 
Sub DOSYALARDAN_VERİ_AL()
    Dim K1 As Workbook, K2 As Workbook
    Dim K3 As Workbook, S1 As Worksheet
    Dim X As Integer, Satır As Integer, Son_Satır As Long
    Dim Klasör As Object, Kaynak_Klasör As String, Dosya As String
    
    Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Kaynak dosyaları içeren klasörü seçin", 50, &H0)
    
    If Klasör = "Masaüstü" Or Klasör = "Desktop" Then
        Kaynak_Klasör = Environ("UserProfile") & "\Desktop\"
    ElseIf Not Klasör Is Nothing Then
        Kaynak_Klasör = Klasör.Items.Item.Path
    Else
        MsgBox "İşleme devam edbilmek için klasör seçimi yapmalısınız !" & Chr(10) & _
        "İşleminiz iptal edilmiştir.", vbCritical
        Exit Sub
    End If
    
    On Error Resume Next
    
    Set K1 = ThisWorkbook
    Set K2 = Workbooks.Add(1)
    Dosya = Dir(Kaynak_Klasör & "\*.xls")
    Satır = 2
    
    Application.ScreenUpdating = False
    
    Do
        If Dosya <> "" And Dosya <> K1.Name And InStr(1, Dosya, "Dosya") = 0 Then
            DoEvents
            Application.DisplayAlerts = False
            Set K3 = Workbooks.Open(Kaynak_Klasör & "\" & Dosya, False, False)
            Application.DisplayAlerts = True
            Set S1 = K3.Sheets(1)
            
            Son_Satır = S1.Cells(Rows.Count, 1).End(3).Row
            S1.Range("A2:AA" & Son_Satır).Copy _
            K2.Sheets("Sayfa1").Range("A" & Satır)
            Satır = K2.Sheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row + 2
            
            K3.Close True
            Dosya = Dir
        Else
            Dosya = Dir
        End If
    Loop While Dosya <> ""
    
    K2.Sheets("Sayfa1").Cells.EntireColumn.AutoFit
[COLOR=blue]    K2.SaveAs (Kaynak_Klasör & "\Dosya_" & Format(Now, "dd_mm_yyyy_hh_mm_ss"))
[/COLOR]    K2.Close True
    
    Set K1 = Nothing
    Set K2 = Nothing
    Set K3 = Nothing
    
    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Genişletmek için tıkla ...
 
D

desk

Katılım
17 Ekim 2005
Mesajlar
288
Excel Vers. ve Dili
excel 2010 türkçe
Bu kodda şöyle bir sorun var. Tüm dosyaları aktarıyor okey fakat dosya sanırım satır boşsa duruyor ve diğer dosyaya geçiyor fakat her dosyada son satırın altında 4--5 satırda c veya d sütunundan başlayan veri varsa bunları aktarmıyor. Burda son satırın tümü boşsa diğer dosyaya geç yapabilirmiyiz.??
 
D

desk

Katılım
17 Ekim 2005
Mesajlar
288
Excel Vers. ve Dili
excel 2010 türkçe
17.05.2014 15 tanim 16.07.2014
a kod isim
b kod1 isim
c kod2 isim
d kod3 isim
ÖRNEK TARİH SATIRINI ALIP ALTINI (alt kısım tanım sütunundan başlıyor) ALMIYOR.
 
F

feridici_genc

Katılım
28 Şubat 2011
Mesajlar
605
Excel Vers. ve Dili
2010 - Türkçe - Win10 x64
Bu konu hakkında benimde bir yardıma ihtiyacım var.
Korhan Bey'in ilk mesajında paylaştığı kodlar düzgün çalışıyor.
Bu dosyaların belirli sütunlarını nasıl aldırabiliriz?
Örneğin: B sütunu, E sütunu, I sütunu, K sütunu ve M sütunlarını alt alta sadece değer olarak işlem yapmasını istesem nasıl olmalı kodlar?
Bir de her dosya için aşağıdaki resmide bulunan pencere çıkıyor.

 
O

ordulu82

Altın Üye
Katılım
24 Mart 2006
Mesajlar
209
Altın Üyelik Bitiş Tarihi
28-07-2027
Korhan Ayhan' Alıntı:
Merhaba,

Aşağıdaki kodu boş bir excel kitabına uygulayın.

Kodu çalıştırdığınızda seçtiğiniz klasör altında yeni bir excel sayfası oluşturulur ve içine klasör altındaki dosyaların ilk sayfalarındaki veriler alt alta aktarılır.

Yeni excel dosyası "Dosya_gg_aa_yyyy_ss_dd_nn" ismi ile kayıt edilir. Kırmızı bölüm günün tarihi ve saatidir.

Kod: 
Option Explicit
 
Sub DOSYALARDAN_VERİ_AL()
    Dim K1 As Workbook, K2 As Workbook
    Dim K3 As Workbook, S1 As Worksheet
    Dim X As Integer, Satır As Integer, Son_Satır As Long
    Dim Klasör As Object, Kaynak_Klasör As String, Dosya As String
    
    Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Kaynak dosyaları içeren klasörü seçin", 50, &H0)
    
    If Klasör = "Masaüstü" Or Klasör = "Desktop" Then
        Kaynak_Klasör = Environ("UserProfile") & "\Desktop\"
    ElseIf Not Klasör Is Nothing Then
        Kaynak_Klasör = Klasör.Items.Item.Path
    Else
        MsgBox "İşleme devam edbilmek için klasör seçimi yapmalısınız !" & Chr(10) & _
        "İşleminiz iptal edilmiştir.", vbCritical
        Exit Sub
    End If
    
    On Error Resume Next
    
    Set K1 = ThisWorkbook
    Set K2 = Workbooks.Add(1)
    Dosya = Dir(Kaynak_Klasör & "\*.xls")
    Satır = 2
    
    Application.ScreenUpdating = False
    
    Do
        If Dosya <> "" And Dosya <> K1.Name And InStr(1, Dosya, "Dosya") = 0 Then
            DoEvents
            Application.DisplayAlerts = False
            Set K3 = Workbooks.Open(Kaynak_Klasör & "\" & Dosya, False, False)
            Application.DisplayAlerts = True
            Set S1 = K3.Sheets(1)
            
            Son_Satır = S1.Cells(Rows.Count, 1).End(3).Row
            S1.Range("A2:AA" & Son_Satır).Copy _
            K2.Sheets("Sayfa1").Range("A" & Satır)
            Satır = K2.Sheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row + 2
            
            K3.Close True
            Dosya = Dir
        Else
            Dosya = Dir
        End If
    Loop While Dosya <> ""
    
    K2.Sheets("Sayfa1").Cells.EntireColumn.AutoFit
[COLOR=blue]    K2.SaveAs (Kaynak_Klasör & "\Dosya_" & Format(Now, "dd_mm_yyyy_hh_mm_ss"))
[/COLOR]    K2.Close True
    
    Set K1 = Nothing
    Set K2 = Nothing
    Set K3 = Nothing
    
    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Genişletmek için tıkla ...
Üstadım bu kod sadece sayfa1 adlı sayfaları bileştiriyor. Peki sayfa adları farklı ise yada bir dosyada birden fazla dosya varsa ve bunları birleştirmek istersek kodu nasıl düzenlememiz gerekiyor.
 
M

M_K_o

Katılım
7 Mayıs 2014
Mesajlar
9
Excel Vers. ve Dili
türkce 13
merhabalar. sacma bir soru olcak belki ama bana bu formülde 2 sayfayı almasını istiyorum bir yapamadım yardımcı ola bilirmisniz
 
K

kadirerol42

Katılım
29 Kasım 2016
Mesajlar
1
Excel Vers. ve Dili
exel 2007
Dosyadan veri alma

Sub DOSYALARDAN_VERİ_AL()
Dim K1 As Workbook, K2 As Workbook
Dim K3 As Workbook, S1 As Worksheet
Dim X As Integer, Satır As Integer, Son_Satır As Long
Dim Klasör As Object, Kaynak_Klasör As String, Dosya As String

Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Kaynak dosyaları içeren klasörü seçin", 50, &H0)

If Klasör = "Masaüstü" Or Klasör = "Desktop" Then
Kaynak_Klasör = Environ("UserProfile") & "\Desktop\"
ElseIf Not Klasör Is Nothing Then
Kaynak_Klasör = Klasör.Items.Item.Path
Else
MsgBox "İşleme devam edbilmek için klasör seçimi yapmalısınız !" & Chr(10) & _
"İşleminiz iptal edilmiştir.", vbCritical
Exit Sub
End If

On Error Resume Next

Set K1 = ThisWorkbook
Set K2 = Workbooks.Add(1)
Dosya = Dir(Kaynak_Klasör & "\*.xls")
Satır = 2

Application.ScreenUpdating = False

Do
If Dosya <> "" And Dosya <> K1.Name And InStr(1, Dosya, "Dosya") = 0 Then
DoEvents
Application.DisplayAlerts = False
Set K3 = Workbooks.Open(Kaynak_Klasör & "\" & Dosya, False, False)
Application.DisplayAlerts = True
Set S1 = K3.Sheets(1)

Son_Satır = S1.Cells(Rows.Count, 1).End(3).Row
S1.Range("A2:AA" & Son_Satır).Copy _
K2.Sheets("Sayfa1").Range("A" & Satır)
Satır = K2.Sheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row + 2

K3.Close True
Dosya = Dir
Else
Dosya = Dir
End If
Loop While Dosya <> ""

K2.Sheets("Sayfa1").Cells.EntireColumn.AutoFit
K2.SaveAs (Kaynak_Klasör & "\Dosya_" & Format(Now, "dd_mm_yyyy_hh_mm_ss"))
 K2.Close True

Set K1 = Nothing
Set K2 = Nothing
Set K3 = Nothing

Application.ScreenUpdating = True

MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

----




Korhan Hocam Merhabalar,

Sizin yazdığınız ekteki Makroda 20 tane exel çalışma sayfasından verileri alıp tek dosyada birleştiriyoruz.
Birleştirme Esnasında Bazı Verilerin (E,AO hücre aralığını )gelmemesini istiyoruz.
Bize Lazım Olan A,B,C,D ve AP Hücrelerindeki verilerin birleştirme olarak gelmesini istiyoruz.
Bu konuda yardımlarınızı bekliyoruz veya Sizin Bu Konuda Bize Başka Makro Öneriniz varsa belirtirmisiniz.
Saygılarımla;
 
H

Hepgel

Katılım
18 Ocak 2019
Mesajlar
234
Excel Vers. ve Dili
Office 2013
Merhaba Altın üye olmamız gerekiyor.
Birden Fazla Excel Dosyam var ve onlar şitler var tek excelde birleştirmek istiyorum.
Yardımcı olabilirmisiniz....
 
umit1907

umit1907

Altın Üye
Katılım
9 Mayıs 2007
Mesajlar
219
Excel Vers. ve Dili
365 TR
Altın Üyelik Bitiş Tarihi
18-04-2029
Merhabalar,
birleştirilen dosyada bir satırada Excel çalışma kitabının ismini yazdırabilirmiyiz bu çalışmada
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,760
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
umit1907' Alıntı:
Merhabalar,
birleştirilen dosyada bir satırada Excel çalışma kitabının ismini yazdırabilirmiyiz bu çalışmada
Genişletmek için tıkla ...
Alternatif kod

Kod: 
Dim Sayfa_Adı As String
Dim dosya_adı As String
Dim mesaj As String

Sub Kapyalayarakverial()
dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name

'Application.ScreenUpdating = False
mesaj2 = MsgBox("Sayfayı temizlemek istiyormusunuz.?", vbYesNo + vbInformation, " Temizleme Penceresi")

If mesaj2 = vbYes Then

Range(Cells(1, 1), Cells(Rows.Count, Columns.Count)).ClearContents
Rows("1:" & Rows.Count).Interior.ColorIndex = xlNone

Cells.UnMerge
Cells.Borders(xlDiagonalDown).LineStyle = xlNone
Cells.Borders(xlDiagonalUp).LineStyle = xlNone
Cells.Borders(xlEdgeLeft).LineStyle = xlNone
Cells.Borders(xlEdgeTop).LineStyle = xlNone
Cells.Borders(xlEdgeBottom).LineStyle = xlNone
Cells.Borders(xlEdgeRight).LineStyle = xlNone
Cells.Borders(xlInsideVertical).LineStyle = xlNone
Cells.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("a1").Select
End If

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

mesaj = MsgBox("Veri almak için aşağıdakilerden birini seçenz. " & Chr(10) & Chr(10) & _
"Yanlızca değerleri almak için  EVET  tıklayınız. " & Chr(10) & Chr(10) & _
"Biçimleri ve değerleri almak için   HAYIR  tıklayınız. " & Chr(10) & Chr(10) & _
"Biçimleri ve Formülleri almak için    İPTAL tıklayınız..?", vbYesNoCancel + vbInformation, "Veri alımı")
Liste9 (Kaynak)
'Application.ScreenUpdating = True

MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
   
Set Obj = Nothing
Set Klasor = Nothing
Exit Sub
Hata: MsgBox Err.Description, vbExclamation, "Error #" & Err.Number

End Sub

Private Sub Liste9(yol As String)
Dim fL As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")

aranan_Uzanti = LCase(fL.GetExtensionName(Application.AddIns.Item(1).FullName))
Dim wb As Workbook
For Each Dosya In fL.GetFolder(yol).Files
Uzanti = LCase(fL.GetExtensionName(Dosya.Name))

If aranan_Uzanti = "xlam" Then
If Uzanti = "xls" Or Uzanti = "xlsm" Or Uzanti = "xlsx" Or Uzanti = "xlsb" Then
Else
GoSub Atla
End If
End If

If aranan_Uzanti = "xla" Then
If Uzanti <> "xls" Then
GoSub Atla
Else
End If
End If

If ThisWorkbook.Name <> Dosya.Name And "~$" & ThisWorkbook.Name <> Dosya.Name Then
yenidosya_adı = Dosya.Name
Set wb = Workbooks.Open(Dosya, Password:="", WriteResPassword:="")
For r = 1 To Workbooks(yenidosya_adı).Sheets.Count
If Sheets(r).Name <> "Data" Then

Sayfa_Adı2 = Workbooks(yenidosya_adı).Sheets(r).Name

If WorksheetFunction.CountA(Sheets(Sheets(r).Name).Cells) > 0 Then
sat1 = Workbooks(yenidosya_adı).Sheets(Sheets(r).Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sut1 = Workbooks(yenidosya_adı).Sheets(Sheets(r).Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
If WorksheetFunction.CountA(Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells) > 1 Then
sat2 = Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
Else
sat2 = 1
End If

If sat1 + sat2 + 2 > Workbooks(dosya_adı).Sheets(Sayfa_Adı).Rows.Count Then
Windows(dosya_adı).Activate
son = Workbooks(dosya_adı).Sheets.Count + 1
ThisWorkbook.Sheets.Add
ThisWorkbook.Sheets(ActiveSheet.Name).Select
ThisWorkbook.Sheets(ActiveSheet.Name).Move After:=Sheets(son)
Sayfa_Adı = ThisWorkbook.ActiveSheet.Name
sat2 = 1
Windows(yenidosya_adı).Activate
End If

Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, 1).Value = Dosya
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, 2).Value = yenidosya_adı
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, 3).Value = Sheets(r).Name
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Range(Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, 1), Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, sut1)).Interior.ColorIndex = 8
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, 2).Interior.ColorIndex = 6
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, 3).Interior.ColorIndex = 45

If WorksheetFunction.CountA(Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells) > 0 Then
sat2 = Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
Else
sat2 = 1
End If

Workbooks(yenidosya_adı).Sheets(Sayfa_Adı2).Range(Workbooks(yenidosya_adı).Sheets(Sayfa_Adı2).Cells(1, 1), Workbooks(yenidosya_adı).Sheets(Sayfa_Adı2).Cells(sat1, sut1)).Copy

If mesaj = vbYes Then
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Range("A" & sat2).PasteSpecial Paste:=3
End If

If mesaj = vbNo Then
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Range("A" & sat2).PasteSpecial Paste:=7
End If

If mesaj = vbCancel Then
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Range("A" & sat2).PasteSpecial Paste:=1
End If

End If
End If
Next r
Dir Dosya

Application.CutCopyMode = False
wb.Close False
End If
Atla:

Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).SubFolders
Liste9 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
 
Son düzenleme:
PriveT

PriveT

Katılım
8 Ekim 2009
Mesajlar
642
Excel Vers. ve Dili
Office 2010 & 2016 TR
Altın Üyelik Bitiş Tarihi
26-12-2023
halit3' Alıntı:
Alternatif kod

Kod:
Genişletmek için tıkla ...
Hocam emeğinize sağlık. Bunun bir de bu makrolu ana dosyaya değil de hedef klasör sorup yeni bir dosya olarak kaydedenini yazabilir misiniz? Böylece hem makrolu ana dosyamızı sabit bir program olarak kullanabiliriz hem de yeni oluşturulan dosya makrosuz bir dosya olur.
Bir de ikinci bir alternatif olarak; mümkünatı var mıdır, çok mu zor olur bilmiyorum. Eğer dosyada birden fazla sayfa varsa hangi sayfaları kopyalamak istediğimizi soran bir makro yazılabilir mi?
Böylece birinci alternatifi sadece 1. sayfanın kopyalanmasında pratik olarak kullanabiliriz, ikinci alternatifle de daha karışık dosyaları çözeriz.
Arşivime alayım, gün gelir lazım olur :)
İyi günler.
 
umit1907

umit1907

Altın Üye
Katılım
9 Mayıs 2007
Mesajlar
219
Excel Vers. ve Dili
365 TR
Altın Üyelik Bitiş Tarihi
18-04-2029
Teşekkürler Halit Abi eline sağlık
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,760
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
İkinci sorunuz i
PriveT' Alıntı:
Hocam emeğinize sağlık. Bunun bir de bu makrolu ana dosyaya değil de hedef klasör sorup yeni bir dosya olarak kaydedenini yazabilir misiniz? Böylece hem makrolu ana dosyamızı sabit bir program olarak kullanabiliriz hem de yeni oluşturulan dosya makrosuz bir dosya olur.
Bir de ikinci bir alternatif olarak; mümkünatı var mıdır, çok mu zor olur bilmiyorum. Eğer dosyada birden fazla sayfa varsa hangi sayfaları kopyalamak istediğimizi soran bir makro yazılabilir mi?
Böylece birinci alternatifi sadece 1. sayfanın kopyalanmasında pratik olarak kullanabiliriz, ikinci alternatifle de daha karışık dosyaları çözeriz.
Arşivime alayım, gün gelir lazım olur :)
İyi günler.
Genişletmek için tıkla ...
İkinci sorunuz için kod
makroyu çalıştırmadan önce veri alınacak sayfaları ekli resimdeki gibi birinci satıra yazınız.

Kod: 
Dim Kaynak As String
Dim sat1 As String
Dim sat2 As String
Dim Sayfa_Adı As String
Dim dosya_adı As String

Sub deneme()
sat2 = 1

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

Klasor2 = ThisWorkbook.Path & "\Dasyalar"
If CreateObject("Scripting.FileSystemObject").FolderExists(Klasor2) = False Then
MkDir Klasor2
End If

ThisWorkbook.Sheets(ActiveSheet.Name).Rows("1:1").Copy

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
uzanti = LCase(fL.GetExtensionName(ThisWorkbook.Name))

Workbooks.Add
Range("a1").PasteSpecial Paste:=3
Application.CutCopyMode = False
Range("A2").Select

dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name
Liste4 (Kaynak)
Range("A1").Select

If uzanti = "xls" Then
FileFormatNum = -4143
ElseIf uzanti = "xlsm" Then
FileFormatNum = 52
ElseIf uzanti = "xlsx" Then
FileFormatNum = 51
ElseIf uzanti = "xlsb" Then
FileFormatNum = 50
Else
FileFormatNum = 56
End If


Dim Kayıt_Yeri As String
yer = Klasor2
sat2 = CreateObject("Scripting.FileSystemObject").GetFolder(yer).Files.Count + 1
Kayıt_Yeri = yer & "\dosya" & sat2

ActiveWorkbook.SaveAs Kayıt_Yeri, FileFormat:=FileFormatNum   'Uzanti
ActiveWorkbook.Close False
MsgBox "Dosyanız aşağıdaki isimle kayıt edilmiştir." & Chr(10) & Kayıt_Yeri, vbInformation, "U Y A R I"

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 Sub


Private Sub Liste4(yol As String)
Dim fL As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")

aranan_Uzanti = LCase(fL.GetExtensionName(Application.AddIns.Item(1).FullName))
Dim wb As Workbook
For Each dosya In fL.GetFolder(yol).Files

If ThisWorkbook.Name <> dosya Then
Set wb = Workbooks.Open(dosya)
sıra = Sheets.Count
yenidosya_adı = ActiveWorkbook.Name
sat2 = sat2 + 1

For r = 1 To sıra
aranan = Sheets(r).Name
bulunan = 0

For j = 1 To Workbooks(dosya_adı).Sheets(Sayfa_Adı).Range("a1:z1").Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
If Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(1, j) = aranan Then
bulunan = 1
End If
Next j

If bulunan = 1 Then

If WorksheetFunction.CountA(Worksheets(Sheets(r).Name).Cells) > 0 Then
satır = Worksheets(Sheets(r).Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sutun = Worksheets(Sheets(r).Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
kesisim = Worksheets(Sheets(r).Name).Cells(satır, sutun).Address(False, False)
Else
satır = 1
sutun = 1
kesisim = Worksheets(Sheets(r).Name).Cells(satır, sutun).Address(False, False)
End If

Worksheets(ActiveSheet.Name).Range("A1:" & kesisim).Copy
Windows(dosya_adı).Activate

If sat2 + satır > Workbooks(dosya_adı).Sheets(Sayfa_Adı).Rows.Count Then
Sheets.Add
Sheets(ActiveSheet.Name).Move After:=Sheets(Workbooks(dosya_adı).Sheets.Count)
Sayfa_Adı = ActiveSheet.Name
sat2 = 1
End If

If WorksheetFunction.CountA(Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells) > 0 Then
sat2 = Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
Else
sat2 = 1
End If


sat1 = "A" & sat2 + 1

Range(sat1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Range(Cells(sat2, 1), Cells(sat2, sutun)).Interior.ColorIndex = 8
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, "A").Value = dosya
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, "B").Value = "sayfa adı " & aranan

End If

Windows(yenidosya_adı).Activate
Next r

Application.CutCopyMode = False
wb.Close False
Application.Visible = True

End If

Next


On Error GoTo sonraki
For Each f In fL.GetFolder(yol).SubFolders
Kaynak = f.Path
MsgBox Kaynak
Liste4 (Kaynak)
sonraki:
Next

Set fL = Nothing
End Sub
Yeni Bit Eşlem Resmi.jpg
 
Son düzenleme:
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,760
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu da birinci sorunuz için

Kod: 
Dim Sayfa_Adı As String
Dim dosya_adı As String
Dim mesaj As String
Sub Kapyalayarakverial22()
dosya_adı = ActiveWorkbook.Name

Sayfa_Adı = ActiveSheet.Name

'Application.ScreenUpdating = False
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


Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
uzanti = LCase(fL.GetExtensionName(ThisWorkbook.Name))

Workbooks.Add
dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name

mesaj = MsgBox("Veri almak için aşağıdakilerden birini seçenz. " & Chr(10) & Chr(10) & _
"Yanlızca değerleri almak için  EVET  tıklayınız. " & Chr(10) & Chr(10) & _
"Biçimleri ve değerleri almak için   HAYIR  tıklayınız. " & Chr(10) & Chr(10) & _
"Biçimleri ve Formülleri almak için    İPTAL tıklayınız..?", vbYesNoCancel + vbInformation, "Veri alımı")

Liste9 (Kaynak)
'Application.ScreenUpdating = True
Dim Kayıt_Yeri As String
yer = CreateObject("wscript.Shell").SpecialFolders("Desktop")
sat2 = CreateObject("Scripting.FileSystemObject").GetFolder(yer).Files.Count + 1
Kayıt_Yeri = yer & "\dosya" & sat2

If uzanti = "xls" Then
FileFormatNum = -4143
ElseIf uzanti = "xlsm" Then
FileFormatNum = 52
ElseIf uzanti = "xlsx" Then
FileFormatNum = 51
ElseIf uzanti = "xlsb" Then
FileFormatNum = 50
Else
FileFormatNum = 56
End If
ActiveWorkbook.SaveAs Kayıt_Yeri & "." & uzanti, FileFormat:=FileFormatNum  'Uzanti
ActiveWorkbook.Close False
MsgBox "Dosyanız aşağıdaki isimle kayıt edilmiştir." & Chr(10) & Kayıt_Yeri, vbInformation, "U Y A R I"
Application.DisplayAlerts = 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 Sub
 
Private Sub Liste9(yol As String)
Dim fL As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")

aranan_Uzanti = LCase(fL.GetExtensionName(Application.AddIns.Item(1).FullName))
Dim wb As Workbook
For Each dosya In fL.GetFolder(yol).Files
uzanti = LCase(fL.GetExtensionName(dosya.Name))

If aranan_Uzanti = "xlam" Then
If uzanti = "xls" Or uzanti = "xlsm" Or uzanti = "xlsx" Or uzanti = "xlsb" Then
Else
GoSub atla
End If
End If

If aranan_Uzanti = "xla" Then
If uzanti <> "xls" Then
GoSub atla
Else
End If
End If

If ThisWorkbook.Name <> dosya.Name And "~$" & ThisWorkbook.Name <> dosya.Name Then
yenidosya_adı = dosya.Name
Set wb = Workbooks.Open(dosya, Password:="", WriteResPassword:="")
For r = 1 To Workbooks(yenidosya_adı).Sheets.Count
If Workbooks(yenidosya_adı).Sheets(r).Name <> "Data" Then

Sayfa_Adı2 = Workbooks(yenidosya_adı).Sheets(r).Name

If WorksheetFunction.CountA(Workbooks(yenidosya_adı).Sheets(Sheets(r).Name).Cells) > 0 Then
sat1 = Workbooks(yenidosya_adı).Sheets(Sheets(r).Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sut1 = Workbooks(yenidosya_adı).Sheets(Sheets(r).Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
If WorksheetFunction.CountA(Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells) > 1 Then
sat2 = Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
Else
sat2 = 1
End If

If sat1 + sat2 + 2 > Workbooks(dosya_adı).Sheets(Sayfa_Adı).Rows.Count Then
Windows(dosya_adı).Activate
son = Workbooks(dosya_adı).Sheets.Count + 1
Workbooks(dosya_adı).Sheets.Add
Workbooks(dosya_adı).Sheets(ActiveSheet.Name).Select
Workbooks(dosya_adı).Sheets(ActiveSheet.Name).Move After:=Sheets(son)
Sayfa_Adı = Workbooks(dosya_adı).ActiveSheet.Name
sat2 = 1
Windows(yenidosya_adı).Activate
End If

Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, 1).Value = dosya
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, 2).Value = yenidosya_adı
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, 3).Value = Sheets(r).Name
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Range(Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, 1), Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, sut1)).Interior.ColorIndex = 8
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, 2).Interior.ColorIndex = 6
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, 3).Interior.ColorIndex = 45

If WorksheetFunction.CountA(Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells) > 0 Then
sat2 = Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
Else
sat2 = 1
End If

Workbooks(yenidosya_adı).Sheets(Sayfa_Adı2).Range(Workbooks(yenidosya_adı).Sheets(Sayfa_Adı2).Cells(1, 1), Workbooks(yenidosya_adı).Sheets(Sayfa_Adı2).Cells(sat1, sut1)).Copy

If mesaj = vbYes Then
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Range("A" & sat2).PasteSpecial Paste:=3
End If

If mesaj = vbNo Then
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Range("A" & sat2).PasteSpecial Paste:=7
End If

If mesaj = vbCancel Then
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Range("A" & sat2).PasteSpecial Paste:=1
End If

End If
End If
Next r
Dir dosya

Application.CutCopyMode = False
wb.Close False
End If
atla:

Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).SubFolders
Liste9 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
 
umit1907

umit1907

Altın Üye
Katılım
9 Mayıs 2007
Mesajlar
219
Excel Vers. ve Dili
365 TR
Altın Üyelik Bitiş Tarihi
18-04-2029
Halit Abi kusura bakma ben şu şekilde yapmak istiyorum. sutunların karşısına yazılmasını istiyordum. Yani AB sutununa dosya adlarını yazmak istiyorum.
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,760
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Dosyanın bu bölümündeki kırmızı yerleri istenen sutün numarasını yazınız.

Rich (BB code): 
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, 1).Value = dosya
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, 2).Value = yenidosya_adı
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, 3).Value = Sheets(r).Name
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Range(Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, 1), Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, sut1)).Interior.ColorIndex = 8
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, 2).Interior.ColorIndex = 6
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, 3).Interior.ColorIndex = 45
1 i AB için 28
2 yi AC için 29
3 ü AD için 30
yapınız.

veya böyle yapınız.

Rich (BB code): 
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, "AB").Value = dosya
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, "AC").Value = yenidosya_adı
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, "AD").Value = Sheets(r).Name
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Range(Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, 1), Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, sut1)).Interior.ColorIndex = 8
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2,"AC").Interior.ColorIndex = 6
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Cells(sat2, "AD").Interior.ColorIndex = 45
 
Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Üst