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

umit1907

umit1907

Altın Üye
Katılım
9 Mayıs 2007
Mesajlar
230
Excel Vers. ve Dili
365 TR
Altın Üyelik Bitiş Tarihi
18-04-2029
Halit abi ben bütün satırların karşısına hangi dosya ya ait olduğunu yazmak istiyorum yalnız .
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,812
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu kodlar kopyalama ile verileri alıyor
zaten verileri alırken dasya adını ve sayfa adını yazıyor bunu bütün hücrelere yazdırmanın ne anlamı var anlamadım.
 
umit1907

umit1907

Altın Üye
Katılım
9 Mayıs 2007
Mesajlar
230
Excel Vers. ve Dili
365 TR
Altın Üyelik Bitiş Tarihi
18-04-2029
halit3' Alıntı:
Bu kodlar kopyalama ile verileri alıyor
zaten verileri alırken dasya adını ve sayfa adını yazıyor bunu bütün hücrelere yazdırmanın ne anlamı var anlamadım.
Genişletmek için tıkla ...
Abi firmalardan fiyat teklifleri geliyor bunları tek excelde birleştirip fiyat analizinde kullanmak için dosya ismi firma ismi olacak şeklide kullanacağım
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,812
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
umit1907' Alıntı:
Halit abi ben bütün satırların karşısına hangi dosya ya ait olduğunu yazmak istiyorum yalnız .
Genişletmek için tıkla ...
Bu dediğinizi A sutünu için yaptım ama tasvip etmiyorum çünkü kopyalama işlemi son sutün da veri olursa kod çalışmaz

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

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

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


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

Workbooks(dosya_adı).Sheets(Sayfa_Adı).Range("A1").Select

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

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("B" & sat2).PasteSpecial Paste:=3 '3
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Range("A" & sat2 & ":A" & sat2 + sat1 - 1).Value = dosya.Name & " " & Sheets(r).Name
End If

If mesaj = vbNo Then
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Range("B" & sat2).PasteSpecial Paste:=7
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Range("A" & sat2 & ":A" & sat2 + sat1 - 1).Value = dosya.Name & " " & Sheets(r).Name
End If

If mesaj = vbCancel Then
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Range("B" & sat2).PasteSpecial Paste:=1
Workbooks(dosya_adı).Sheets(Sayfa_Adı).Range("A" & sat2 & ":A" & sat2 + sat1 - 1).Value = dosya.Name & " " & Sheets(r).Name
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
 
G

GkhnZkrn

Katılım
12 Ekim 2019
Mesajlar
1
Excel Vers. ve Dili
Excel 2019 Türkçe
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 ...
Merhaba; Kod ile ilgili sorun yaşıyorum. Nerde hata yaptığımı bulamadım yardımcı olmanızı rica ediyorum;

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

Çalıştır dediğim de kod'un SaveAs yerini işaretliyor.
 
M

m.ensar

Altın Üye
Katılım
5 Nisan 2016
Mesajlar
384
Excel Vers. ve Dili
office 10 türkçe
Altın Üyelik Bitiş Tarihi
25-10-2025
halit3' Alıntı:
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
Genişletmek için tıkla ...
Halit hocam bu konu uzun zamandır kullanılmamış ama bu kodlarla alakalı bir iki düzenleme yapabilir misiniz? 1) ilk satırlar genelde sütun bilgilerini içeriyor dolayısıyla ilk satırları 1 defa çekse yada kaçıncı satırdan başlayacağını biz belirlesek. 2) kitap içerisinde ki tek bir sayfayı örneğin klasör de 5 ayrı kitap var bu kitapların sadece ikinci sayfalarını yada 3. sayfalarını çektirebilir miyiz? 3) sayfa da olan formülleri görmezden gelebilir mi yada yok sayabilir mi? zira diyelim C sütununda formül var biz çekmişiz o sütunu 500. satıra ama işlediğimiz veri 44. satırda bitiyor 44 ten sonrasını çekmese formül var diye satırları dolu kabul etmese bunlar olabilir mi?
 
M

m.ensar

Altın Üye
Katılım
5 Nisan 2016
Mesajlar
384
Excel Vers. ve Dili
office 10 türkçe
Altın Üyelik Bitiş Tarihi
25-10-2025
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 ...
Korhan Hocam bu kod mükemmel benim de şöyle bir sorum olacak bu kod İşlem yapmak istediğimiz verilerin bulunduğu klasör MASAÜSTÜNDE ise listeleri birleştiriyor yalnız D sürücüsünde ise boş bir sayfa veriyor. D sürücüsünde ki klasördeki listeleri birleştirmek için ne yapmalıyım? birde misal bir liste oluşturdum TOPLAM VERİLER adında 1. satıra sütun bilgilerini girdim Kalsörde bulunan verileri bu listeye çekebilir mi?
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,812
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
m.ensar' Alıntı:
Halit hocam bu konu uzun zamandır kullanılmamış ama bu kodlarla alakalı bir iki düzenleme yapabilir misiniz? 1) ilk satırlar genelde sütun bilgilerini içeriyor dolayısıyla ilk satırları 1 defa çekse yada kaçıncı satırdan başlayacağını biz belirlesek. 2) kitap içerisinde ki tek bir sayfayı örneğin klasör de 5 ayrı kitap var bu kitapların sadece ikinci sayfalarını yada 3. sayfalarını çektirebilir miyiz? 3) sayfa da olan formülleri görmezden gelebilir mi yada yok sayabilir mi? zira diyelim C sütununda formül var biz çekmişiz o sütunu 500. satıra ama işlediğimiz veri 44. satırda bitiyor 44 ten sonrasını çekmese formül var diye satırları dolu kabul etmese bunlar olabilir mi?
Genişletmek için tıkla ...
37 nolu mesajdaki kod sizin istediğinizin büyük bir bölümünü yapıyor orada sayfa görüntüsüde var birinci satıra veri alacağınız sayfa isimlerini yazın veriler alınacaktır diğer bir sorunuz için kopyalama Worksheets(ActiveSheet.Name).Range("A1:" & kesisim).Copy işlemi burada yapılıyor.
A1 yerine B1 yaparsanız ikinci satırdan itibaren son dolu satıra kadar işlem yapıyor kod formülleri atlamıyor. Formülleride dolu hücre görüyor.
 
M

m.ensar

Altın Üye
Katılım
5 Nisan 2016
Mesajlar
384
Excel Vers. ve Dili
office 10 türkçe
Altın Üyelik Bitiş Tarihi
25-10-2025
Teşekkürler hocam sağolasınız
 
S

solgun

Altın Üye
Katılım
28 Ağustos 2019
Mesajlar
2
Excel Vers. ve Dili
2019 türkçe
Altın Üyelik Bitiş Tarihi
15-09-2025
Halit hocam elinize sağlık. çok işime yarayacak.
Allah gönlünüzdekini hayırlısıyla versin.
 
S

starofnorth97

Katılım
4 Mayıs 2020
Mesajlar
1
Excel Vers. ve Dili
2016-Ingilizce
halit3' Alıntı:
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
Genişletmek için tıkla ...
çok teşekkürler işime yaradı.
 
N

nearperfect

Katılım
26 Haziran 2010
Mesajlar
6
Excel Vers. ve Dili
MS Excel 365 - İngilizce
Merhaba,
Yukarıda örnek kod var ancak ben çalıştıramadım. Bir klasör içerisinde en az 20 olmak üzere çalışma kitapları var. Bu çalışma kitapları içerisinde "Sheet 3" diye bir çalışma sayfası var ve ben bunları bir excel dosyasına alacağı yoluda göstererek alt alta sıralamak istiyorum. Çok denedim ama maalesef yapamadım. Yardımcı olabilir misiniz? Bu sayede en az iki saatimi kurtaracağım.
Desteğiniz için şimdiden çok teşekkür ederim.
 
N

nearperfect

Katılım
26 Haziran 2010
Mesajlar
6
Excel Vers. ve Dili
MS Excel 365 - İngilizce
nearperfect' Alıntı:
Merhaba,
Yukarıda örnek kod var ancak ben çalıştıramadım. Bir klasör içerisinde en az 20 olmak üzere çalışma kitapları var. Bu çalışma kitapları içerisinde "Sheet 3" diye bir çalışma sayfası var ve ben bunları bir excel dosyasına alacağı yoluda göstererek alt alta sıralamak istiyorum. Çok denedim ama maalesef yapamadım. Yardımcı olabilir misiniz? Bu sayede en az iki saatimi kurtaracağım.
Desteğiniz için şimdiden çok teşekkür ederim.
Genişletmek için tıkla ...
bu arada MS Excel 365 ve ingilizce.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,456
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Sürüm bilgilerinizi Profilinize yazarsanız daha sağlıklı olacaktır.

Ayrıca çözüm için örnek dosyalarınızı ve birleştirmek istediğiniz yapıyı gösteren dosyanızı paylaşırsanız cevap almanız daha kolay olur.

Harici dosya yükleme sitelerine yükleyip link verebilirsiniz. (Örnek ; WeTransfer)
 
N

nearperfect

Katılım
26 Haziran 2010
Mesajlar
6
Excel Vers. ve Dili
MS Excel 365 - İngilizce
Korhan Ayhan' Alıntı:
Sürüm bilgilerinizi Profilinize yazarsanız daha sağlıklı olacaktır.

Ayrıca çözüm için örnek dosyalarınızı ve birleştirmek istediğiniz yapıyı gösteren dosyanızı paylaşırsanız cevap almanız daha kolay olur.

Harici dosya yükleme sitelerine yükleyip link verebilirsiniz. (Örnek ; WeTransfer)
Genişletmek için tıkla ...
Merhaba Hocam,

Aslında profilimden düzeltmek istedim ama açıkcası bulamadım nereden düzelteceğimi.

Aşağıda örnek link var. Sheet3' te yer alan sarı ile işaretli kısmı aktarmak istiyorum. Desteğiniz için çok teşekkür ederim

1 öge​




Saygılar
Ufuk
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,456
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Bütün dosyalarınızda aktarılacak sayfa adı Sheet3'mü?

Birde aktarımın nasıl olmasını istiyorsunuz?

Aktarmak istediğiniz dosyaları seçmek ister misiniz? Yoksa sabit yol tanımlayıp bu yoldaki dosyalar mı işleme alınsın?

Verilerin hepsi bir dosyada bir sayfada alt alta mı aktarılsın?
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst