DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
MerhabaMerhabalar iş yerinde karşılaştığım bir problem var excelde iki tane sayfada iki ayrı tablo var başka bir sayfada o iki tablodaki aynı olan verileri alt alta sıralayıp karşılarına fiyatlarıyla birlikte getirilmesini istiyorum. Eğer bunu yapamazsam benim için hiç iyi olmayacak
Merhabalar iş yerinde karşılaştığım bir problem var excelde iki tane sayfada iki ayrı tablo var başka bir sayfada o iki tablodaki aynı olan verileri alt alta sıralayıp karşılarına fiyatlarıyla birlikte getirilmesini istiyorum. Eğer bunu yapamazsam benim için hiç iyi olmayacak
[SIZE="2"] Private Sub Worksheet_Activate()
Dim s1, s2, s3 As Worksheet
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Set s3 = Sheets("Sayfa3")
s3.Select
s3.[a2:b60000] = Empty
For a = 2 To s1.Cells(Rows.Count, 1).End(xlUp).Row
Set b = s2.Range("a1:a" & s2.Cells(Rows.Count, 1).End(xlUp).Row).Find(s1.Cells(a, 1), LookIn:=xlValues, Lookat:=xlWhole)
If Not b Is Nothing Then
satır = b.Address
boş = s3.Cells(Rows.Count, 1).End(3).Row + 1
s3.Range("a" & boş & ":b" & boş).Value = s1.Range("a" & a & ":b" & a).Value
Do
boş = s3.Cells(Rows.Count, 1).End(3).Row + 1
s3.Range("a" & boş & ":b" & boş).Value = s2.Range("a" & b.Row & ":b" & b.Row).Value
Set b = s2.Range("a1:a" & s2.Cells(Rows.Count, 1).End(xlUp).Row).FindNext(b)
If b Is Nothing Then Exit Do
Loop While Not b Is Nothing And b.Address <> satır
End If
Next
End Sub [/SIZE]Merhaba
Yukarıdaki değişen dosyayı inceleyin.
Private Sub CommandButton1_Click()
Dim s1, s2, m As Worksheet
Dim f, f2 As Long: Dim n As Double
Set s2 = Sheets("Asıl Liste")
s2.Range("a1:a" & s2.Cells(Rows.Count, 1).End(xlUp).Row).Replace " ", ""
For Each m In Sheets
If m.Name <> s2.Name Then
Set s1 = Sheets(m.Name)
s1.Range("a1:a" & s1.Cells(Rows.Count, 1).End(xlUp).Row).Replace " ", ""
For a = 2 To s1.Cells(Rows.Count, 1).End(xlUp).Row
f = s1.Cells(Rows.Count, 1).End(xlUp).Row
s1.Range("A2:H" & f).Sort Key1:=s1.Range("a2"), Order1:=xlAscending
f2 = s2.Cells(Rows.Count, 1).End(xlUp).Row + 1
s2.Cells(f2, 1).Select
If WorksheetFunction.CountIf(s2.Range("A2:A" & f2), s1.Cells(a, "A")) = 0 Then
n = WorksheetFunction.CountIf(s1.Range("A2:A" & f), s1.Cells(a, "A"))
s2.Range("A" & f2 & ":H" & f2 + n - 1).Value = s1.Range("A" & a & ":H" & a + n - 1).Value
a = a + n - 2
End If
Next
End If
Next
End Sub