Kapalı Excele veri yazdırma

[valentino06]

Sinan hocam çok teşekkür ederim. Hocam verileri yazılacak Excel ortak alanda olacak. Yolu tanımlıyacağım şekilde düzenleyebilir misin. Hocam. Diğer Excel ise masaüstünde olacak.

 

[sinan05]

Sinan hocam çok teşekkür ederim. Hocam verileri yazılacak Excel ortak alanda olacak. Yolu tanımlıyacağım şekilde düzenleyebilir misin. Hocam. Diğer Excel ise masaüstünde olacak.

Yolu tanımlarız tabi.
fakat saonradan farkettim, aşağıya eklediğim kod değişikliğini yaparmısın;
Son1 = Dosyam.Sheets(i).Range("E65536").End(3).Row kısmını silip
Son1 = Dosyam.Sheets(i).Range("C65536").End(3).Row bunu eklermisin.

 

[EmrExcel16]

Altarnetif olarak deneyiniz.

Option Explicit

Sub Verileri_Aktar()
    Dim Kynk As Workbook, KynkSyf As Worksheet, Hdf As Workbook, HdfSyf As Worksheet
    Dim Yol As String, Dosya_Adi As String, i As Integer, bul As Variant, firstAddress As String, Zamn As Date
    Application.ScreenUpdating = False
    Zamn = Time
    Set Kynk = ThisWorkbook
    Set KynkSyf = Kynk.Sheets("Veri")
    
    Yol = "C:\Users\mesen\Desktop\Örnek\Yeni klasör\Yeni klasör (2)\"
    Dosya_Adi = "8-9.Hafta içi 7.Hafta sonu-Kaynak.xlsx"
 
    Set Hdf = Workbooks.Open(Yol & Dosya_Adi, False, False)
    Set HdfSyf = Hdf.Sheets("Personel Listesi")
    For i = 5 To KynkSyf.Range("D500").End(3).Row
        Set bul = HdfSyf.Range("C1:C100000").Find(KynkSyf.Cells(i, "D"), , xlValues, xlWhole)
        If Not bul Is Nothing Then
            firstAddress = bul.Address
            Do
                If HdfSyf.Range("B" & bul.Row).Value = KynkSyf.Range("P" & i).Value Then
                    HdfSyf.Range("E" & bul.Row).Value = KynkSyf.Range("F" & i).Value
                End If
                Set bul = HdfSyf.Range("C1:C100000").FindNext(bul)
            Loop While Not bul Is Nothing And bul.Address <> firstAddress
        End If
    Next
    Hdf.Close True
    Application.ScreenUpdating = True
    MsgBox Format(Time - Zamn, "hh:mm:ss") & " Surede Islem Tamamlandi" & vbLf & Application.UserName, vbInformation
End Sub

 

[sinan05]

Altarnetif olarak deneyiniz.

Option Explicit

Sub Verileri_Aktar()
    Dim Kynk As Workbook, KynkSyf As Worksheet, Hdf As Workbook, HdfSyf As Worksheet
    Dim Yol As String, Dosya_Adi As String, i As Integer, bul As Variant, firstAddress As String, Zamn As Date
    Application.ScreenUpdating = False
    Zamn = Time
    Set Kynk = ThisWorkbook
    Set KynkSyf = Kynk.Sheets("Veri")
   
    Yol = "C:\Users\mesen\Desktop\Örnek\Yeni klasör\Yeni klasör (2)\"
    Dosya_Adi = "8-9.Hafta içi 7.Hafta sonu-Kaynak.xlsx"

    Set Hdf = Workbooks.Open(Yol & Dosya_Adi, False, False)
    Set HdfSyf = Hdf.Sheets("Personel Listesi")
    For i = 5 To KynkSyf.Range("D500").End(3).Row
        Set bul = HdfSyf.Range("C1:C100000").Find(KynkSyf.Cells(i, "D"), , xlValues, xlWhole)
        If Not bul Is Nothing Then
            firstAddress = bul.Address
            Do
                If HdfSyf.Range("B" & bul.Row).Value = KynkSyf.Range("P" & i).Value Then
                    HdfSyf.Range("E" & bul.Row).Value = KynkSyf.Range("F" & i).Value
                End If
                Set bul = HdfSyf.Range("C1:C100000").FindNext(bul)
            Loop While Not bul Is Nothing And bul.Address <> firstAddress
        End If
    Next
    Hdf.Close True
    Application.ScreenUpdating = True
    MsgBox Format(Time - Zamn, "hh:mm:ss") & " Surede Islem Tamamlandi" & vbLf & Application.UserName, vbInformation
End Sub

Hocam merhaba, emeğinize sağlık. Ben konuyu açan arkadaş için kodlarınızı denedim. Kapalı dosyadaki E sütununa verileri kopyalıyor, fakat G,H,I,J,K,L sütunlarına kaynak dosyadan veri gelmiyor. Bu sutünlarada, kaynak dosyanın G,I,J,K,L,M sütunlarındaki veriler gelmeli. Ayrıca kapalı dosyanın isimleri belirli aralıklarla değişiyormuş, bilginize.

 

[EmrExcel16]

Merhaba Sinan bey, ilginiz ve bilgilendirmeniz için teşekkür ederim , sutunları çoğaltmak istenirse kod içinde aşağıdaki verdiğim kısmı "E" ve "F" harflerini değiştirip çoğaltarak hangi sutunları istiyorsa eklenebilir .

HdfSyf.Range("E" & bul.Row).Value = KynkSyf.Range("F" & i).Value

 

[sinan05]

Merhaba Sinan bey, ilginiz ve bilgilendirmeniz için teşekkür ederim , sutunları çoğaltmak istenirse kod içinde aşağıdaki verdiğim kısmı "E" ve "F" harflerini değiştirip çoğaltarak hangi sutunları istiyorsa eklenebilir .

HdfSyf.Range("E" & bul.Row).Value = KynkSyf.Range("F" & i).Value

Rica ederim. Arkadaş bu bilgilerinizi uygulayacaktır.

 

[valentino06]

Sayın Emre Hocam ve Sinan Hocam çok çok teşekkür ederim Allah Yolunu açık etsin inşallah çok sağolun.

 

[Korhan Ayhan]

Alternatif;

ADO yöntemi;

Tek sorun sayıları "METİN BİÇİMİNDE SAYI" formatında dosyaya aktarıyor. Kullanmak isterseniz deneyebilirsiniz.

Dosya yolunu kod içinden değiştirebilirsiniz. Dilerseniz excel hücresinden aldırabilirsiniz.

Option Explicit

Sub Verileri_Aktar()
    Dim Baglanti As Object, Hedef_Dosya As String
    Dim Yol As String, Veri As Variant, X As Long
    Dim Son As Long, Zaman As Double
   
    Application.ScreenUpdating = False
   
    Zaman = Timer
   
    Set Baglanti = CreateObject("AdoDb.Connection")
  
    Yol = ThisWorkbook.Path & "\Yeni klasör\"
    Hedef_Dosya = Yol & "\" & Dir(Yol & "\*.xls*")
  
    With Baglanti
        .Provider = "Microsoft.Ace.OleDb.12.0"
        .Properties("Data Source") = Hedef_Dosya
        .Properties("Extended Properties") = "Excel 12.0; Hdr=Yes"
        .Open
      
        Son = Cells(Rows.Count, "D").End(3).Row
        Son = WorksheetFunction.Max(6, Son)
       
        Veri = Range("B5:S" & Son).Value
       
        For X = LBound(Veri, 1) To UBound(Veri, 1)
            .Execute _
            "Update [Personel Listesi$] Set " & _
            "[Haftaici] = " & IIf(Veri(X, 5) = Empty, 0, Veri(X, 5)) & _
            ",[Pazar] = " & IIf(Veri(X, 6) = Empty, 0, Veri(X, 6)) & _
            ",[Arefe] = " & IIf(Veri(X, 8) = Empty, 0, Veri(X, 8)) & _
            ",[Bayram 1] = " & IIf(Veri(X, 9) = Empty, 0, Veri(X, 9)) & _
            ",[Bayram 2] = " & IIf(Veri(X, 10) = Empty, 0, Veri(X, 10)) & _
            ",[Bayram 3] = " & IIf(Veri(X, 11) = Empty, 0, Veri(X, 11)) & _
            ",[Bayram 4] = " & IIf(Veri(X, 12) = Empty, 0, Veri(X, 12)) & _
            " Where [Personel Ad Soyad] = '" & _
            Veri(X, 3) & "' And [Çalıştığı Bölüm] = '" & Veri(X, 15) & "'"
        Next
  
        .Close
    End With
   
    Set Baglanti = Nothing
  
    Application.ScreenUpdating = True
  
    MsgBox "Veri aktarımı tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[valentino06]

Sayın Korhan Ayhan Hocam çok teşekkür ederim. Allah kat kat razı olsun inşallah. Hocam Excel adı haftalık değişiyor. Hocam bu kısmı aşmanın bir yolu varmıdır.

 

[Korhan Ayhan]

Klasörün içinde tek excel dosyası mı oluyor?

 

[valentino06]

Evet Hocam tek Excel

 

[Korhan Ayhan]

Koda ekleme yaptım. Tekrar denersiniz. Ben denemedim. Ama mantık olarak çalışması gerekir.