Tablo birleştirme

[haso_excel]

Merhaba arkadaşlar,

İki sheeti A kolonunu referans alarak tüm kolonlarını birleştirerek ayrı bir sheete almak istiyorum. Yardımcı olabilir misiniz lütfen?

 

[Necdet]

Merhaba,

TABLO sayfasında başlıkların olması koşulu ile, aşağıdaki kodları dener misiniz?

Sub Birlestir()
    Dim s1      As Worksheet, _
        Sat     As Long, _
        i       As Long, _
        j       As Integer, _
        Sayfa   As Integer, _
        SonKol  As Integer, _
        Kolon   As Range, _
        Bul     As Range
        
    Application.ScreenUpdating = False
    Sheets("TABLO").Select
    
    i = Cells(Rows.Count, "A").End(3).Row
    If i < 2 Then i = 2
    Range("A2:AA" & i).ClearContents
    Sat = 1
    
    For Sayfa = 1 To 2
    
        If Sayfa = 1 Then
            Set s1 = Sheets("DATABSE2")
        Else
            Set s1 = Sheets("DATABASE1")
        End If
        
        SonKol = s1.Cells(1, Columns.Count).End(1).Column
        
        For i = 2 To s1.Cells(Rows.Count, "A").End(3).Row
        
            Set Bul = Range("A:A").Find(s1.Cells(i, "A"), LookIn:=xlValues)
            If Not Bul Is Nothing Then
                Sat = Bul.Row
            Else
                Sat = Sat + 1
                Cells(Sat, "A") = s1.Cells(i, "A")
            End If
            
            For j = 2 To SonKol
                Set Kolon = Range("1:1").Find(s1.Cells(1, j), LookIn:=xlValues, LookAt:=xlWhole)
                Cells(Sat, Kolon.Column) = s1.Cells(i, j)
            Next j
    
        Next i
                
    Next Sayfa
    
    Application.ScreenUpdating = True
    MsgBox "Birleştirme Tamamlandı....", vbInformation, "N. YEŞERTENER [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
End Sub

 

[haso_excel]

Üstadım elinize sağlık süper birşey olmuş fakat, tablo sheetinde, iki sheet de olan alanları başlık olarak yazılıyken çalışıyor kod. Peki A kolonun referans olacak şekilde, iki sheet de de mevcut olan alanlar (kolon başlıkları) değişken kolon sayısına sahip olursa nasıl olacak. Yani tablo sheetinde hiç başlık olmadan, iki sheete de bakıp başlıklarıda tablo sheetine getirecek bir kod olursa tam istediğim olacak. İlginiz için şimdiden teşekkür ederim.

 

[Necdet]

Merhaba,

Aslında bende genel amaçlı yapmak istemiştim ama işyerinde yeteri kadar zamanım yoktu, bu yüzden biraz hazıra konmak istemiştim

Aşağıdaki kodları deneyiniz.

Not : Başlıklar Alfabetik Sırayla Yazdırılıyor.

Sub Birlestir()
    Dim s1      As Worksheet, _
        Sat     As Long, _
        i       As Long, _
        j       As Integer, _
        Sayfa   As Integer, _
        SonKol  As Integer, _
        Kolon   As Range, _
        Bul     As Range, _
        Dizi()  As Variant, _
        Eski    As String
        
    Application.ScreenUpdating = False
    Sheets("TABLO").Select
    
    i = Cells(Rows.Count, "A").End(3).Row
    If i < 2 Then i = 2
    Cells.Clear
    Range("A1") = "KOD"
    
    Sat = 1
    i = -1
    For Sayfa = 1 To 2  'Başlıklar Diziye Alınıyor
        If Sayfa = 1 Then
            Set s1 = Sheets("DATABASE1")
        Else
            Set s1 = Sheets("DATABASE2")
        End If
        For j = 2 To s1.Cells(1, Columns.Count).End(1).Column
            i = i + 1
            ReDim Preserve Dizi(0 To i)
            Dizi(i) = s1.Cells(1, j)
        Next j
    Next Sayfa          'Başlıklar Diziye Alındı
    
    BubbleSort Dizi
    j = 1
    For i = 0 To UBound(Dizi)   'Başlıklar Sıralı Şekilde Yazılıyor
        If Not Dizi(i) = Eski Then
            Eski = Dizi(i)
            j = j + 1
            Cells(1, j) = Dizi(i)
        End If
    Next i                      'Başlıklar Sıralı Yazıldı
    
    For Sayfa = 1 To 2
    
        If Sayfa = 1 Then
            Set s1 = Sheets("DATABASE2")
        Else
            Set s1 = Sheets("DATABASE1")
        End If
        
        SonKol = s1.Cells(1, Columns.Count).End(1).Column
        
        For i = 2 To s1.Cells(Rows.Count, "A").End(3).Row
        
            Set Bul = Range("A:A").Find(s1.Cells(i, "A"), LookIn:=xlValues)
            If Not Bul Is Nothing Then
                Sat = Bul.Row
            Else
                Sat = Sat + 1
                Cells(Sat, "A") = s1.Cells(i, "A")
            End If
            
            For j = 2 To SonKol
                Set Kolon = Range("1:1").Find(s1.Cells(1, j), LookIn:=xlValues, LookAt:=xlWhole)
                Cells(Sat, Kolon.Column) = s1.Cells(i, j)
            Next j
    
        Next i
                
    Next Sayfa
    
    Cells.EntireColumn.AutoFit
    Application.ScreenUpdating = True
    MsgBox "Birleştirme Tamamlandı....", vbInformation, "N. YEŞERTENER [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
End Sub

'http://support.microsoft.com/kb/133135
Function BubbleSort(TempArray As Variant)
    Dim Temp        As Variant
    Dim i           As Long
    Dim NoExchanges As Boolean
    ' Loop until no more "exchanges" are made.
    Do
        NoExchanges = True
        ' Loop through each element in the array.
        For i = 0 To UBound(TempArray) - 1
            ' If the element is greater than the element
            ' following it, exchange the two elements.
            If TempArray(i) > TempArray(i + 1) Then
'            If StrComp(TempArray(i), TempArray(i + 1), 1) = 1 Then
                NoExchanges = False
                Temp = TempArray(i)
                TempArray(i) = TempArray(i + 1)
                TempArray(i + 1) = Temp
            End If
        Next i
    Loop While Not (NoExchanges)
End Function

 

[haso_excel]

İlginiz için teşekkür ederim üstadım. Fakat Databese 1 e yada Database2 ye herhangi bir kayıt girildiğinde neden birtanesindekini almıyor. Ben sizin dosyanızda, iki database dosyasınada ekleme yaptığımda neden 1000005 kodlu satırı birleştirmez ?

 

[Necdet]

İlginiz için teşekkür ederim üstadım. Fakat Databese 1 e yada Database2 ye herhangi bir kayıt girildiğinde neden birtanesindekini almıyor. Ben sizin dosyanızda, iki database dosyasınada ekleme yaptığımda neden 1000005 kodlu satırı birleştirmez ?

Anladıysam arap olayım

 

[haso_excel]

) Dosya ekte üstadım. Databese1 ve 2 ye ben satır ekledim. Kodu çalıştırdığımda databade2 deki 1100005 olan kodun verileri tabloya gelmedi.

 

[Necdet]

Merhaba,

Sizin dosyanızı aldım, son kodları ekledim, DATABASE2 (ki siz bu adı yanlış yazmışsınız, onu düzelttim, çünkü kodlarda DATABASE2 olarak kullandım) sayfasına satırlar ekledim.

Çatır çatır çalışıyor, işte kanıtı.

 

[haso_excel]

Teşekkürler işlem tamam