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

Merhum İdris SERDAR · 22 Aralık 2021

sedatif33' Alıntı:
https://files.fm/u/9ggpzvftc
linki paylaştım hocam. bir klasör içerisinde bu şekilde s(1) den 850 ye kadar excel dosyası var.
sayfa isimleri hepsinde aynı. içerisindeki tablolar genişlik ve başlıklar aynı kimisi daha çok satır içerebiliyor.
ben bunların hepsini tek bir excel sayfasında alt alta almak istiyorum.

Buradaki dosyayı kullanabilirsiniz.

https://www.excelgurusu.com/dosya-ve-sayfalarinin-tek-sayfada-birlestirilmesi/

.

Korhan Ayhan · 23 Aralık 2021

Siz benim önerdiğim kodu değiştirmeden aynen kullanın. Sadece alttaki bölümleri değiştirip deneyiniz.

Bold bölümü 2 olarak değiştirin.
Son_Satır = S1.Cells(Rows.Count, 1).End(3).Row

Bu satırı;
S1.Range("A2:AA" & Son_Satır).Copy

Eğer başlıklar lazımsa aşağıdaki gibi değiştirin.
S1.Range("B2:M" & Son_Satır).Copy

Eğer başlıklar lazım değilse aşağıdaki gibi değiştirin.
S1.Range("B7:M" & Son_Satır).Copy

sedatif33 · 23 Aralık 2021

Günaydın. Korhan hocam ilginize teşekkür ederim.
dediğiniz şekilde değişiklikleri yaptım ama yine boş excel oluşuyor.
kod şu şekilde

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çiniz...", 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 edebilmek 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, 2).End(3).Row
            S1.Range("B2:M" & 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

İdris hocam sizinde ilginize teşekkür ediyorum. indirdim dosyayı çalıştırdım ama şu şekilde bir hata veriyor

k17yifo.jpg

aaaa

www.hizliresim.com

RBozkurt · 23 Aralık 2021

Kod:

Sub Birleştir()
    Dim AktifDosya As Workbook
    Dim Dosya As Workbook
    Dim DosyaAdi
      
    Set AktifDosya = ActiveWorkbook
  
    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = True
        .Title = "Birleştirilecek Dosyaları Seçin"
      
        If .Show Then
            For Each DosyaAdi In .SelectedItems
                Set Dosya = Workbooks.Open(DosyaAdi)
              
                Dosya.Worksheets(1).UsedRange.Copy AktifDosya.Worksheets(3).Range("A65536").End(xlUp)(7, 1)
              
                Dosya.Close False
                Set Dosya = Nothing
            Next
        End If
    End With
  
    Set AktifDosya = Nothing
End Sub

Bu şekilde bir makro kullanıyorum belki işinize yarar.
Sayfa3'e taşıma yapar.
Aralarına 7 satır boşluk bırakır.

Korhan Ayhan · 23 Aralık 2021

Siz İngilizce sürüm kullanıyorsunuz.

Kod içindeki aşağıdaki satırdaki kırmızı bölümü Sheet1 olarak revize edip deneyiniz. Birden fazla yerde geçiyor hepsini değiştirip deneyiniz.

K2.Sheets("Sayfa1")

sedatif33 · 23 Aralık 2021

Korhan hocam yorduk seni ama halen olmadı. yeni dosya oluşuyor ama boş. kod şu şekilde

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çiniz...", 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 edebilmek 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, 2).End(3).Row
            S1.Range("B2:M" & Son_Satır).Copy
            K2.Sheets("Sheet1").Range ("A" & Satır)
            Satır = K2.Sheets("Sheet1").Cells(Rows.Count, 1).End(3).Row + 2
          
            K3.Close True
            Dosya = Dir
        Else
            Dosya = Dir
        End If
    Loop While Dosya <> ""
 
    K2.Sheets("Sheet1").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

RBozkurt' Alıntı:

Kod:

Sub Birleştir()
    Dim AktifDosya As Workbook
    Dim Dosya As Workbook
    Dim DosyaAdi
     
    Set AktifDosya = ActiveWorkbook
 
    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = True
        .Title = "Birleştirilecek Dosyaları Seçin"
     
        If .Show Then
            For Each DosyaAdi In .SelectedItems
                Set Dosya = Workbooks.Open(DosyaAdi)
             
                Dosya.Worksheets(1).UsedRange.Copy AktifDosya.Worksheets(3).Range("A65536").End(xlUp)(7, 1)
             
                Dosya.Close False
                Set Dosya = Nothing
            Next
        End If
    End With
 
    Set AktifDosya = Nothing
End Sub

Bu şekilde bir makro kullanıyorum belki işinize yarar.
Sayfa3'e taşıma yapar.
Aralarına 7 satır boşluk bırakır.

rbozkurt ilginize teşekkür ederim. sizin kod'da uygulamalar için microsoft visual basic X aboneliği aralık dışı diye ingilizce bir hata veriyor.

Korhan Ayhan · 23 Aralık 2021

Verileri kopyalayan satırdaki alt çizgi işareti silinmiş. Bundan dolayı sonuç alamamışsınız.

Aşağıdaki gibi deneyiniz.

C++:

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çiniz...", 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 edebilmek 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, 2).End(3).Row
            S1.Range("B2:M" & Son_Satır).Copy _
            K2.Sheets("Sheet1").Range("A" & Satır)
            Satır = K2.Sheets("Sheet1").Cells(Rows.Count, 1).End(3).Row + 2
          
            K3.Close True
            Dosya = Dir
        Else
            Dosya = Dir
        End If
    Loop While Dosya <> ""
 
    K2.Sheets("Sheet1").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

By.TRabZonLutm · 17 Aralık 2022

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çiniz...", 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 edebilmek 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

merhaba hocam bu formülü inceledim, sadece istediğim başlıkları ve istediğim sayfadan adından alması için ne yapabilirim.

Korhan Ayhan · 17 Aralık 2022

Merhaba,

Kod içindeki şu saatır sayfayı ifade ediyor.

Set S1 = K3.Sheets(1)

Parantez içindeki 1 ifadesi hedef dosyadaki ilk sıradaki sayfayı ifade eder.

Sizin dosyanızda veri alınacak sayfa adı belli ise aşağıdaki gibi yazabilirsiniz.

Set S1 = K3.Sheets("Sayfa1")

Diğer taraftan alıntı yaptığınız kod "A:AA" sütun aralığını (gerekiyorsa bu aralığı değiştirebilirsiniz) yeni dosyada birleştiriyor. İstediğiniz sütunlar için veri aktarımından sonra gereksiz sütunları silerek sonuca gidebilirsiniz. Bu şekilde sizin için daha pratik olabilir.

By.TRabZonLutm · 18 Aralık 2022

Korhan Ayhan' Alıntı:
Merhaba,

Kod içindeki şu saatır sayfayı ifade ediyor.

Set S1 = K3.Sheets(1)

Parantez içindeki 1 ifadesi hedef dosyadaki ilk sıradaki sayfayı ifade eder.

Sizin dosyanızda veri alınacak sayfa adı belli ise aşağıdaki gibi yazabilirsiniz.

Set S1 = K3.Sheets("Sayfa1")

Diğer taraftan alıntı yaptığınız kod "A:AA" sütun aralığını (gerekiyorsa bu aralığı değiştirebilirsiniz) yeni dosyada birleştiriyor. İstediğiniz sütunlar için veri aktarımından sonra gereksiz sütunları silerek sonuca gidebilirsiniz. Bu şekilde sizin için daha pratik olabilir.

Hocam sütunu ayarladım fakat bu sefer tüm excel dosyalarındaki başlıkları da alıyor. sadece bir sayfanın başlığını almasını nasıl sağlayabilirim.
6.satırda gördüğünüz gibi boşluk bıraktı maalesef. diğer bir husus da , formülleri de alıyor. yeni dosyaya aktarırken formülleri almayacağı şekilde nasıl ayarlarım? sadece değerleri alsın.

Korhan Ayhan · 18 Aralık 2022

Önerdiğim kod #4 nolu mesaj ekinde paylaşılan dosyalara göre hazırlanmıştır. O dosyalardaki tüm başlıklar birleşecek dosyaya aktarılması talep edilmiş.

Verilerde (Başlıklar dahil) 2. satırdan başlıyor.

Doğal olarak bu kodların sizin beklentilerinizi karşılamaması normaldir.

Önerim şu olabilir...

Verileri aktarırken başlık satırını dahil etmeyin. Sonrasında kod bitiminde bu satırı aşağıdaki gibi kendiniz oluşturursunuz. A1:E1 hücrelerine başlık bilgilerini yazar.. Siz kendinize göre düzenlersiniz.

Range("A1:E1").Value = Array("Başlık 1", "Başlık 2", "Başlık 3", "Başlık 4", "Başlık 5")

By.TRabZonLutm · 18 Aralık 2022

Korhan Ayhan' Alıntı:
Önerdiğim kod #4 nolu mesaj ekinde paylaşılan dosyalara göre hazırlanmıştır. O dosyalardaki tüm başlıklar birleşecek dosyaya aktarılması talep edilmiş.

Verilerde (Başlıklar dahil) 2. satırdan başlıyor.

Doğal olarak bu kodların sizin beklentilerinizi karşılamaması normaldir.

Önerim şu olabilir...

Verileri aktarırken başlık satırını dahil etmeyin. Sonrasında kod bitiminde bu satırı aşağıdaki gibi kendiniz oluşturursunuz. A1:E1 hücrelerine başlık bilgilerini yazar.. Siz kendinize göre düzenlersiniz.

Range("A1:E1").Value = Array("Başlık 1", "Başlık 2", "Başlık 3", "Başlık 4", "Başlık 5")

Dahil etmeyince boşluk bırakıyor hocam ekrandaki gibi

Korhan Ayhan · 18 Aralık 2022

Evet boşluk bırakıyor. Çünkü talep bu şekildeydi.

Aşağıdaki satırı bulup sondaki 2 değerini 1 olarak düzeltip deneyiniz.

Satır = K2.Sheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row + 2

By.TRabZonLutm · 20 Aralık 2022

Korhan Ayhan' Alıntı:
Önerdiğim kod #4 nolu mesaj ekinde paylaşılan dosyalara göre hazırlanmıştır. O dosyalardaki tüm başlıklar birleşecek dosyaya aktarılması talep edilmiş.

Verilerde (Başlıklar dahil) 2. satırdan başlıyor.

Doğal olarak bu kodların sizin beklentilerinizi karşılamaması normaldir.

Önerim şu olabilir...

Verileri aktarırken başlık satırını dahil etmeyin. Sonrasında kod bitiminde bu satırı aşağıdaki gibi kendiniz oluşturursunuz. A1:E1 hücrelerine başlık bilgilerini yazar.. Siz kendinize göre düzenlersiniz.

Range("A1:E1").Value = Array("Başlık 1", "Başlık 2", "Başlık 3", "Başlık 4", "Başlık 5")

Son_Satır = S1.Cells(Rows.Count, 1).End(3).Row
S1.Range("A4:H4" & Son_Satır).Copy _
K2.Sheets("Sayfa1").Range("A" & Satır)
K2.Sheets("Sayfa1").Range("A1:H1").Value = Array("Başlık 1", "Başlık 2", "Başlık 3", "Başlık 4", "Başlık 5")
Satır = K2.Sheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row + 1

hocam bu bölüme ekledim artık yeni dosyanın başına başlık 1 başlık 2 ... diye yazıyor
ayrıda +2 olan bölümü +1 olarak ekledim onda da sorun yok artık boşluk bırakmıyor.
sadece tek sorun aktarırken formülleri de aktarıyor. sadece değerler kalsın istiyorum, yapabilir miyiz?

daha önce böyle bir kod tasarlamıştınız : https://www.excel.web.tr/threads/excel-kitabini-sadece-degerler-ile-kaydetme-formueller-olmadan.204874/post-1148319

fakat burda bir buton yardımıyla dosyayı tekrar kaydetmek gerekiyordu.

bunu yukarda yazdığınız makroya ilave edemez miyiz birleştir dediğininde formülsüz birleştirsin.

Korhan Ayhan · 20 Aralık 2022

Bu satırı,

S1.Range("A4:H4" & Son_Satır).Copy _
K2.Sheets("Sayfa1").Range("A" & Satır)

Bununla değiştirip deneyiniz..

S1.Range("A4:H4" & Son_Satır).Copy
K2.Sheets("Sayfa1").Range("A" & Satır).PasteSpecial Paste:=xlPasteValues

By.TRabZonLutm · 20 Aralık 2022

Korhan Ayhan' Alıntı:
Bu satırı,

S1.Range("A4:H4" & Son_Satır).Copy _
K2.Sheets("Sayfa1").Range("A" & Satır)

Bununla değiştirip deneyiniz..

S1.Range("A4:H4" & Son_Satır).Copy
K2.Sheets("Sayfa1").Range("A" & Satır).PasteSpecial Paste:=xlPasteValues

Her dosyayı aktarırken böyle soruyor hocam.

Bir de aktaracagim dosyadan hücre tarih olarak seçili olmasına rağmen aktardığı dosyada böyle gösteriyor tekrardan tarih olarak düzeltmem gerekiyor

Korhan Ayhan · 20 Aralık 2022

Bu bahsettiklerinizin hepsi normal uyarılardır. Biçim olayıda şu şekildedir. Boş bir excel dosyası açtığınızda siz bir biçimlendirme yapmadığınız sürece tüm hücrelerin biçimi GENEL şeklindedir. Yapıştırma işlemi olarak sadece DEĞERLER olsun dediğiniz için tarihlerde GENEL biçimiyle görünecektir. Eğer biçimleri yapıştırmak sorun yaratmayacaksa bir önceki mesajımda önerdiğim kodun altına aşağıdaki satırı ekleyerek deneme yapabilirsiniz.

K2.Sheets("Sayfa1").Range("A" & Satır).PasteSpecial Paste:= xlPasteFormats

Gelen uyarıyı görmemek içinde aşağıdaki işlemi yaparak deneyiniz.

Bu satırı;

K3.Close True

Aşağıdaki gibi değiştiriniz.

Application.DisplayAlerts = False
K3.Close True
Application.DisplayAlerts = True

By.TRabZonLutm · 20 Aralık 2022

Korhan Ayhan' Alıntı:
Bu bahsettiklerinizin hepsi normal uyarılardır. Biçim olayıda şu şekildedir. Boş bir excel dosyası açtığınızda siz bir biçimlendirme yapmadığınız sürece tüm hücrelerin biçimi GENEL şeklindedir. Yapıştırma işlemi olarak sadece DEĞERLER olsun dediğiniz için tarihlerde GENEL biçimiyle görünecektir. Eğer biçimleri yapıştırmak sorun yaratmayacaksa bir önceki mesajımda önerdiğim kodun altına aşağıdaki satırı ekleyerek deneme yapabilirsiniz.

K2.Sheets("Sayfa1").Range("A" & Satır).PasteSpecial Paste:= xlPasteFormats

Gelen uyarıyı görmemek içinde aşağıdaki işlemi yaparak deneyiniz.

Bu satırı;

K3.Close True

Aşağıdaki gibi değiştiriniz.

Application.DisplayAlerts = False
K3.Close True
Application.DisplayAlerts = True

Helal olsun suanlik hiçbir sıkıntı yok. Artık uyarı çıkmıyor ve tarihleri olduğu gibi aktarıyor . İstediğim başlığı yeni sayfada direkt aktarıyor, boşluk bırakmıyor alt altta yapıştırıyor. Çok teşekkür ederim

By.TRabZonLutm · 20 Aralık 2022

Korhan Ayhan' Alıntı:
Bu bahsettiklerinizin hepsi normal uyarılardır. Biçim olayıda şu şekildedir. Boş bir excel dosyası açtığınızda siz bir biçimlendirme yapmadığınız sürece tüm hücrelerin biçimi GENEL şeklindedir. Yapıştırma işlemi olarak sadece DEĞERLER olsun dediğiniz için tarihlerde GENEL biçimiyle görünecektir. Eğer biçimleri yapıştırmak sorun yaratmayacaksa bir önceki mesajımda önerdiğim kodun altına aşağıdaki satırı ekleyerek deneme yapabilirsiniz.

K2.Sheets("Sayfa1").Range("A" & Satır).PasteSpecial Paste:= xlPasteFormats

Gelen uyarıyı görmemek içinde aşağıdaki işlemi yaparak deneyiniz.

Bu satırı;

K3.Close True

Aşağıdaki gibi değiştiriniz.

Application.DisplayAlerts = False
K3.Close True
Application.DisplayAlerts = True

Tekrar düzeltme yapmam gerekiyor hocam. Kişisel bilgisayarımda sorunsuz çalıştı fakat ağ üzerinde denedim fakat boş Excel olarak kopyaladı maalesef ( dosyalar masaüstünde değil)

Korhan Ayhan · 20 Aralık 2022

Ağ ortamnında kodu F8 tuşu ile adım adım çalıştırıp test edebilirsiniz. Başkada yapabileceğim birşey yok maalesef.

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

Merhum İdris SERDAR

Moderatör

Korhan Ayhan

Administrator

sedatif33

k17yifo.jpg

RBozkurt

𐱅𐰇𐰼𐰚

Korhan Ayhan

Administrator

sedatif33

Korhan Ayhan

Administrator

By.TRabZonLutm

Korhan Ayhan

Administrator

By.TRabZonLutm

Korhan Ayhan

Administrator

By.TRabZonLutm

Korhan Ayhan

Administrator

By.TRabZonLutm

Korhan Ayhan

Administrator

By.TRabZonLutm

Korhan Ayhan

Administrator

By.TRabZonLutm

By.TRabZonLutm

Korhan Ayhan

Administrator