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

PriveT · 9 Mayıs 2019

halit3' Alıntı:
Bu da birinci sorunuz için

Kod:

...

Teşekkürler. Emeğinize sağlık.

PriveT · 9 Mayıs 2019

halit3' Alıntı:
İkinci sorunuz i

İkinci sorunuz için kod
makroyu çalıştırmadan önce veri alınacak sayfaları ekli resimdeki gibi birinci satıra yazınız.

Ekli dosyayı görüntüle 205910

Denedim, resimdeki hatayı verdi.
Belki de ben bir hata yaptım, bilemiyorum.
Yine de emeğiniz için teşekkür ederim.

umit1907 · 9 Mayıs 2019

Halit abi ben bütün satırların karşısına hangi dosya ya ait olduğunu yazmak istiyorum yalnız .

halit3 · 9 Mayıs 2019

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 · 9 Mayıs 2019

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.

Abi firmalardan fiyat teklifleri geliyor bunları tek excelde birleştirip fiyat analizinde kullanmak için dosya ismi firma ismi olacak şeklide kullanacağım

halit3 · 10 Mayıs 2019

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 .

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

halit3 · 10 Mayıs 2019

PriveT' Alıntı:
Denedim, resimdeki hatayı verdi.
Belki de ben bir hata yaptım, bilemiyorum.
Yine de emeğiniz için teşekkür ederim.

Ekli dosyayı görüntüle 205917

37 nolu mesajdaki kodu yeniden güncelledim

PriveT · 10 Mayıs 2019

halit3' Alıntı:
37 nolu mesajdaki kodu yeniden güncelledim

Teşekkürler

GkhnZkrn · 12 Ekim 2019

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

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.ensar · 12 Mart 2020

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

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.ensar · 12 Mart 2020

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

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 · 12 Mart 2020

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?

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.ensar · 12 Mart 2020

Teşekkürler hocam sağolasınız

solgun · 28 Nisan 2020

Halit hocam elinize sağlık. çok işime yarayacak.
Allah gönlünüzdekini hayırlısıyla versin.

starofnorth97 · 19 Temmuz 2020

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

çok teşekkürler işime yaradı.

nearperfect · 27 Temmuz 2020

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.

nearperfect · 27 Temmuz 2020

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.

bu arada MS Excel 365 ve ingilizce.

Korhan Ayhan · 27 Temmuz 2020

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)

nearperfect · 27 Temmuz 2020

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)

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

https://wetransfer.com/downloads/7ddc1802df755052a30c9f4854295c6520200727133839/89861911204c4b387c6eba3c25c7222420200727133900/35d034

1 öge

Saygılar
Ufuk

Korhan Ayhan · 27 Temmuz 2020

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?

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

PriveT

PriveT

umit1907

halit3

Uzman

umit1907

halit3

Uzman

halit3

Uzman

PriveT

GkhnZkrn

m.ensar

m.ensar

halit3

Uzman

m.ensar

solgun

starofnorth97

nearperfect

nearperfect

Korhan Ayhan

Administrator

nearperfect

Korhan Ayhan

Administrator