[Yardım]  AYNI KLASÖRDEKİ 6 ADET DOSYAYI BİRLEŞTİRME

VBA Makrolar ile ilgili sormak istedikleriniz, yapmak istedikleriniz hakkında yardım alabileceğiniz bölümdür.

AYNI KLASÖRDEKİ 6 ADET DOSYAYI BİRLEŞTİRME

İleti#1)  asevincel » 14 Mar 2019 06:55

Merhaba,

Ekteki 6 adet dosyayı herhafta farklı sistemlerden rapor çekiyor ve tek tek birleştiriyorum. Bunu makro ile yapma konuusnda yardımlarınızı rica ediyorum. Makroda takıldığım kısım aşağıdaki ilk adımlar. Düzenletme kısımlarını sanırım kendim hallederim.

Satır sayıları her raporda değişen ekteki 6 dosyayı birleştirsin. Birleştirirken "O" sütünuna (sağdaki son verilerin hepsinin yanına) ilgili dosyadan gelen her satır için, eğer dosya ismi ;

"ine" ise "İNEGÖL"
"tur" ise "TURGUTLU"
"ank" ise "ANKARA"
"hen" ise "HENDEK"
"hay" ise "HAYRABOLU"
"tar" ise "TARSUS"

Yardımlarınız için şimdiden teşekkürler.
files.zip
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
asevincel
 
Kayıt: 21 Şub 2017 15:41
Meslek: Özel Sektör
Yaş: 36
İleti: 6
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İstanbul

Cevap: AYNI KLASÖRDEKİ 6 ADET DOSYAYI BİRLEŞTİRME

İleti#2)  hemso41 » 14 Mar 2019 10:28

Merhaba Öncelikle bir modül ekleyiniz;
sonra aşağıdaki kodları yapıştırınız.
Bir buton aracılığıyla dosyabak makrosunu çalıştırınız.
6 şehir ve dosya uzantısı xls olduğu düşünülerek kod yazılmıştır.Bu uğraşıya bir duanıza talibim. Saygılarımla
Kod: Tümünü seç
Private Const yol As String = "C:\Users\serdar\Desktop\files\" 'klasör yolunuzu değiştiriniz

Sub dosyabak()

Dim dosya_adi As String 'dosya adı
Dim dosya_uzantisi As String 'açmak istediğiniz dosya uzantısı
   
    dosya_uzantisi = "xls" 'başka dosya isterseniz değiştiriniz örnel xlm,xlsx
   
   
    dosya_adi = Dir(yol)
    Do Until dosya_adi = ""
        If Right(dosya_adi, 3) = dosya_uzantisi Then bilgi_getir dosya_adi
        dosya_adi = Dir
    Loop


End Sub

Private Sub bilgi_getir(dosya_adi As String)

Dim kaynak As Workbook 'kaynak dosya
Dim satir As Integer 'boş satir no
Dim ssatir As Integer 'son dolu satır no
Dim sehir As String 'dosyadaki şehir adı


    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set hedef = ActiveWorkbook
    Set kaynak = Workbooks.Open(yol & dosya_adi)
    ssatir = kaynak.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
   
        kaynak.Sheets("Sheet1").Range("A1:n" & ssatir).Copy 'kopyalama
        satir = Sayfa1.Range("A" & Rows.Count).End(xlUp).Row + 1 'ana sayfadaki boş satır
        Sayfa1.Range("A" & satir).PasteSpecial xlPasteAll 'verileri yapıştır
        Select Case Left(dosya_adi, 3)
            Case "ank"
                sehir = "Ankara"
            Case "hay"
                sehir = "HAYRABOLU"
            Case "hen"
                sehir = "HENDEK"
            Case "ine"
                sehir = "İNEGÖL"
            Case "tar"
                sehir = "TARSUS"
            Case "tur"
                sehir = "TURGUTLU"
               
        End Select
        MsgBox satir & vbCrLf & ssatir
        Sayfa1.Range("O" & satir & ":O" & satir + ssatir) = sehir
        kaynak.Close (False)
       
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Set kaynak = Nothing
   
Exit Sub

    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Kullanıcı avatarı
hemso41
Siteye Alışmış
 
Kayıt: 22 Eyl 2015 08:04
Meslek: BİLGİ İŞLEM
Yaş: 39
İleti: 377
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: izmir/karşıyaka

Cevap: AYNI KLASÖRDEKİ 6 ADET DOSYAYI BİRLEŞTİRME

İleti#3)  veyselemre » 14 Mar 2019 14:46

Kod: Tümünü seç
Sub veriCek()
    Set adoCN = CreateObject("ADODB.Connection")
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Data Source") = ThisWorkbook.FullName
    adoCN.Properties("Extended Properties") = "Excel 12.0; HDR=Yes"
    adoCN.Open
    Set rs = CreateObject("Adodb.RecordSet")
    dosyalar = Array("ank", "hay", "hen", "ine", "tar", "tur")
    ekler = Array("ANKARA", "HAYRABOLU", "HENDEK", "İNEGÖL", "TARSUS", "TURGUTLU")
    Cells.Clear
    For i = 0 To 5
        strSQL = "Select *,'" & ekler(i) & "' From [Sheet1$] IN '' [Excel 12.0;Database=" & ThisWorkbook.Path & "\" & _
                 dosyalar(i) & ".xls] WHERE [Product Name] IS NULL OR NOT ([Product Name] like 'Summary%' OR [Product Name] like 'Grand%')"
        rs.Open strSQL, adoCN, 1, 1
        Cells(Rows.Count, 1).End(3).Offset(1).CopyFromRecordset rs
        rs.Close
    Next i
    adoCN.Close
    Set rs = Nothing
    Set adoCN = Nothing
    With Range("A2:F" & Cells(Rows.Count, 1).End(3).Row).SpecialCells(xlCellTypeBlanks)
        .NumberFormat = "General"
        .FormulaR1C1 = "=R[-1]C"
    End With
    With Range("A2").CurrentRegion
        .Copy
        .PasteSpecial xlPasteValues
        .Columns.AutoFit
    End With
    Application.CutCopyMode = False
End Sub
Kullanıcı avatarı
veyselemre
Siteye Alışmış
 
Kayıt: 28 Nis 2015 15:53
Meslek: SERBEST
Yaş: 104
İleti: 358
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Ankara / Çubuk

Cevap: Cevap: AYNI KLASÖRDEKİ 6 ADET DOSYAYI BİRLEŞTİRME

İleti#4)  asevincel » 14 Mar 2019 16:13

veyselemre yazdı:
Kod: Tümünü seç
Sub veriCek()
    Set adoCN = CreateObject("ADODB.Connection")
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Data Source") = ThisWorkbook.FullName
    adoCN.Properties("Extended Properties") = "Excel 12.0; HDR=Yes"
    adoCN.Open
    Set rs = CreateObject("Adodb.RecordSet")
    dosyalar = Array("ank", "hay", "hen", "ine", "tar", "tur")
    ekler = Array("ANKARA", "HAYRABOLU", "HENDEK", "İNEGÖL", "TARSUS", "TURGUTLU")
    Cells.Clear
    For i = 0 To 5
        strSQL = "Select *,'" & ekler(i) & "' From [Sheet1$] IN '' [Excel 12.0;Database=" & ThisWorkbook.Path & "\" & _
                 dosyalar(i) & ".xls] WHERE [Product Name] IS NULL OR NOT ([Product Name] like 'Summary%' OR [Product Name] like 'Grand%')"
        rs.Open strSQL, adoCN, 1, 1
        Cells(Rows.Count, 1).End(3).Offset(1).CopyFromRecordset rs
        rs.Close
    Next i
    adoCN.Close
    Set rs = Nothing
    Set adoCN = Nothing
    With Range("A2:F" & Cells(Rows.Count, 1).End(3).Row).SpecialCells(xlCellTypeBlanks)
        .NumberFormat = "General"
        .FormulaR1C1 = "=R[-1]C"
    End With
    With Range("A2").CurrentRegion
        .Copy
        .PasteSpecial xlPasteValues
        .Columns.AutoFit
    End With
    Application.CutCopyMode = False
End Sub


Hocam ellerine sağlık çok güzel çalışıyor. Hızlı ve düzenli. Fakat fabrika isimlerini A sütunu değilde verilerin en sağına eklemek için kodu nasıl değiştirmek gerekiyor.

Saygılar.
Kullanıcı avatarı
asevincel
 
Kayıt: 21 Şub 2017 15:41
Meslek: Özel Sektör
Yaş: 36
İleti: 6
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İstanbul

REKLAM
Excel Logo XML Oluşturucu
Logo Object Designer ile Uyarlama

Cevap: AYNI KLASÖRDEKİ 6 ADET DOSYAYI BİRLEŞTİRME

İleti#5)  veyselemre » 14 Mar 2019 18:12

Kod: Tümünü seç
    End With
    Columns("A:A").Cut
    Columns("P:P").Insert Shift:=xlToRight
    Application.CutCopyMode = False
End Sub
Kullanıcı avatarı
veyselemre
Siteye Alışmış
 
Kayıt: 28 Nis 2015 15:53
Meslek: SERBEST
Yaş: 104
İleti: 358
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Ankara / Çubuk

Cevap: Cevap: AYNI KLASÖRDEKİ 6 ADET DOSYAYI BİRLEŞTİRME

İleti#6)  asevincel » 15 Mar 2019 07:28

hemso41 yazdı:Merhaba Öncelikle bir modül ekleyiniz;
sonra aşağıdaki kodları yapıştırınız.
Bir buton aracılığıyla dosyabak makrosunu çalıştırınız.
6 şehir ve dosya uzantısı xls olduğu düşünülerek kod yazılmıştır.Bu uğraşıya bir duanıza talibim. Saygılarımla
Kod: Tümünü seç
Private Const yol As String = "C:\Users\serdar\Desktop\files\" 'klasör yolunuzu değiştiriniz

Sub dosyabak()

Dim dosya_adi As String 'dosya adı
Dim dosya_uzantisi As String 'açmak istediğiniz dosya uzantısı
   
    dosya_uzantisi = "xls" 'başka dosya isterseniz değiştiriniz örnel xlm,xlsx
   
   
    dosya_adi = Dir(yol)
    Do Until dosya_adi = ""
        If Right(dosya_adi, 3) = dosya_uzantisi Then bilgi_getir dosya_adi
        dosya_adi = Dir
    Loop


End Sub

Private Sub bilgi_getir(dosya_adi As String)

Dim kaynak As Workbook 'kaynak dosya
Dim satir As Integer 'boş satir no
Dim ssatir As Integer 'son dolu satır no
Dim sehir As String 'dosyadaki şehir adı


    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set hedef = ActiveWorkbook
    Set kaynak = Workbooks.Open(yol & dosya_adi)
    ssatir = kaynak.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
   
        kaynak.Sheets("Sheet1").Range("A1:n" & ssatir).Copy 'kopyalama
        satir = Sayfa1.Range("A" & Rows.Count).End(xlUp).Row + 1 'ana sayfadaki boş satır
        Sayfa1.Range("A" & satir).PasteSpecial xlPasteAll 'verileri yapıştır
        Select Case Left(dosya_adi, 3)
            Case "ank"
                sehir = "Ankara"
            Case "hay"
                sehir = "HAYRABOLU"
            Case "hen"
                sehir = "HENDEK"
            Case "ine"
                sehir = "İNEGÖL"
            Case "tar"
                sehir = "TARSUS"
            Case "tur"
                sehir = "TURGUTLU"
               
        End Select
        MsgBox satir & vbCrLf & ssatir
        Sayfa1.Range("O" & satir & ":O" & satir + ssatir) = sehir
        kaynak.Close (False)
       
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Set kaynak = Nothing
   
Exit Sub

    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub


Hocam eline emeğine sağlık. Teşekkürler.
Kullanıcı avatarı
asevincel
 
Kayıt: 21 Şub 2017 15:41
Meslek: Özel Sektör
Yaş: 36
İleti: 6
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İstanbul

REKLAM
ETA - Excel Konsolide Raporlama
ETA Excel Personel Entegre Raporu

Cevap: AYNI KLASÖRDEKİ 6 ADET DOSYAYI BİRLEŞTİRME

İleti#7)  hemso41 » 15 Mar 2019 14:36

Kod: Tümünü seç
MsgBox satir & vbCrLf & ssatir

satırı fazlalık bu satırı silebilirsiniz test amaçlı kullanmıştım.
Kullanıcı avatarı
hemso41
Siteye Alışmış
 
Kayıt: 22 Eyl 2015 08:04
Meslek: BİLGİ İŞLEM
Yaş: 39
İleti: 377
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: izmir/karşıyaka


Forum Genel Makro Soruları

Online Kullanıcılar

Bu forumu görüntüleyenler: ASYAASYA, Google [Bot], Google Adsense [Bot], Yandex[Bot] ve 2 misafir

Bumerang - Yazarkafe