DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
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
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