hücrede bulunan sayıları bulup aktarma yapma

[hakan_demirkan]

arkadaşlar işim gereği yapmam gereken bir hayli zaman kaybettiğim bir iş için yardımınıza ihtiyacım var. TUM,BURO1,BURO2 sayfalarım var benim istediğim BURO1 ve BURO2 de bulunan sayıların (tarihlerin) TUM adlı sayfadaki ilgili yerlere aktarımını sağlamak istiyorum örnek dosyayı gönderiyorum yardımlarınız için şimdiden tşk ederiz.

 

[Korhan Ayhan]

Selamlar,

İlk olarak "TÜM " isimli sayfanızın isminin sonundaki boşluk karakterini siliniz.

Daha sonra aşağıdaki kodu deneyiniz.

Option Explicit
 
Private Sub CommandButton1_Click()
    Dim Hücre As Range, SAYFA As Worksheet, BUL As Range, ADRES As String
        
    Application.ScreenUpdating = False
    
    Sheets("TÜM").Range("B2:B65536").ClearContents
    For Each SAYFA In ThisWorkbook.Worksheets
        If SAYFA.Name <> "TÜM" Then
            On Error Resume Next
            For Each Hücre In SAYFA.Range("B2:B65536").SpecialCells(xlCellTypeConstants, 23)
                Set BUL = Sheets("TÜM").Range("A:A").Find(Hücre.Offset(0, -1), LookAt:=xlWhole)
                If Not BUL Is Nothing Then
                ADRES = BUL.Address
                Do
                    If BUL.Offset(0, 1) = "" Then
                        BUL.Offset(0, 1) = Hücre.Value
                    Else
                        BUL.Offset(0, 1) = BUL.Offset(0, 1) & " / " & Hücre.Value
                    End If
                Set BUL = Sheets("TÜM").Range("A:A").Cells.FindNext(BUL)
                Loop While Not BUL Is Nothing And BUL.Address <> ADRES
                End If
            Next
            On Error GoTo 0
        End If
    Next
        
    Set BUL = Nothing
 
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[hakan_demirkan]

ellirinize sağlık hocam çok güzel olmuş Saygılarla