• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

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.
Genişletmek için tıkla ...


Buradaki dosyayı kullanabilirsiniz.


.
 
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
 
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 www.hizliresim.com
 
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.
 
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")
 
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.
Genişletmek için tıkla ...

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.
 
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
 
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
Genişletmek için tıkla ...
merhaba hocam bu formülü inceledim, sadece istediğim başlıkları ve istediğim sayfadan adından alması için ne yapabilirim.
 
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.
 
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.
Genişletmek için tıkla ...
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.
sdib43t.png
 
Son düzenleme:
Ö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")
 
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")
Genişletmek için tıkla ...
Dahil etmeyince boşluk bırakıyor hocam ekrandaki gibi
 
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
 
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")
Genişletmek için tıkla ...
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/ex...ydetme-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.
 
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
 
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
Genişletmek için tıkla ...
Her dosyayı aktarırken böyle soruyor hocam.
JD3nbq.md.jpeg


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

JD3xqp.jpeg
 
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
 
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
Genişletmek için tıkla ...
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
 
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
Genişletmek için tıkla ...
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)
 
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.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst