Resimdeki örneği formül ile nasıl yapabilirim yardımcı olabilecek var mı?
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
işe yaradı teşekkürler ama birden fazla sayfada kullanamıyorum bunun hakkında yardımcı olabilir misinizörnek dosyayı incelermisiniz.
Sub Birlestir()
On Error Resume Next
Application.ScreenUpdating = False
For Each Syf In ActiveWorkbook.Sheets
Syf.Select
Set Alan = Syf.Range("A1:B10") 'Birlestirilecek alan
Set Dic = CreateObject("Scripting.Dictionary")
Hucre = Alan.Value
For i = 1 To UBound(Hucre, 1)
Bulunan = Hucre(i, 1)
If Dic.Exists(Bulunan) Then
Dic(Hucre(i, 1)) = Dic(Hucre(i, 1)) & "," & Hucre(i, 2)
Else
Dic(Hucre(i, 1)) = Hucre(i, 2)
End If
Next
Syf.Range("e1").Value = "KOD"
Syf.Range("f1").Value = "BOX"
Alan.Range("e2").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.keys) ' Birleşenlerin gösterileceği alan
Alan.Range("f2").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.items)
Range("E1:F1").Font.Bold = True
Range("E1:F1").Font.Color = -16776961
Range(Range("E1"), Range("E1").SpecialCells(xlLastCell)).Select
With Selection.Borders
.LineStyle = xlContinuous
.Color = vbBlack
.Weight = xlThin
End With
Syf.Range("e1").Select
Next Syf
Application.ScreenUpdating = True
End Sub
İstediğim sonuca ulaşamadım maalesef 3 haneli rakamlarda sıkıntı yaratıyor.Deneyin
Kod:Sub Birlestir() On Error Resume Next Application.ScreenUpdating = False For Each Syf In ActiveWorkbook.Sheets Syf.Select Set Alan = Syf.Range("A1:B10") 'Birlestirilecek alan Set Dic = CreateObject("Scripting.Dictionary") Hucre = Alan.Value For i = 1 To UBound(Hucre, 1) Bulunan = Hucre(i, 1) If Dic.Exists(Bulunan) Then Dic(Hucre(i, 1)) = Dic(Hucre(i, 1)) & "," & Hucre(i, 2) Else Dic(Hucre(i, 1)) = Hucre(i, 2) End If Next Syf.Range("e1").Value = "KOD" Syf.Range("f1").Value = "BOX" Alan.Range("e2").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.keys) ' Birleşenlerin gösterileceği alan Alan.Range("f2").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.items) Range("E1:F1").Font.Bold = True Range("E1:F1").Font.Color = -16776961 Range(Range("E1"), Range("E1").SpecialCells(xlLastCell)).Select With Selection.Borders .LineStyle = xlContinuous .Color = vbBlack .Weight = xlThin End With Syf.Range("e1").Select Next Syf Application.ScreenUpdating = True End Sub
Merhabaörnek dosyayı incelermisiniz.