B sayfaından A sayfasına Aktarma

[ANTALYA 01]

Merhabalar

Ekteki çalışmada aşağıdaki anlattığım işlemi yapacak makroya ihtiyacım var.B sayfasındaki C sütunundaki Rakamlar ile A sayfasındaki I sütunundaki ve K sütunundaki rakamları aynı ise B sayfasındaki B sütunundaki isimleri A Sayfasının G sütununa ismi yazmasını istiyorum.

 

[Korhan Ayhan]

Selamlar,

Tablolarınızda mükerrer değerler mevcut. Bu durumda eşleştirmeler neye göre yapılacak ?

Örneğin 30 ve 75 değerleri birden fazla satırda geçmektedir. Bu durumda hangi satıra hangi isim yazılacak neye göre belirlenecek?

 

[ANTALYA 01]

K

Merhabalar

Haklısınız o zaman şöyle yapalım B sayfasında C sütununda ilk 75 in A sütunundaki kodu 3030166 A sayfasında (ilk) 75 rakamına I ve K Sütunlarında hangi sütunda denk gelirse G Sütununa ismi F Sütununa kodu yazsın böylelikle çift mükerrerlerin hangi satıra gideceği belli olur.
30 tl için B Sayfasının C Sütunun 28.satırındaki (ilk) 30 tl A sayfasındaki ilk 30 tl olan K.16 Satır A sayfasının G Sütununa B Sayfasındaki Bu sütunundaki 28.satırındaki BÜLENT İsmini Kod 3140007 Asütununu A sayfasının F16.Satıra yazsın.
Sonuç Şöyle olur
A Sayfasının F ve G Sütununda
3140007 BÜLENT 30
3030188 TUBA 30
3030166 MEHMET 75
1010014 AKIN 75

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub RAKAM_EŞLEŞTİR()
    Dim X As Long, BUL As Range, Adres As String, Say As Integer
    Sheets("A").Range("G2:G65536,L2:L65536").ClearContents
    For X = 2 To Sheets("B").Range("C65536").End(3).Row
    If WorksheetFunction.CountIf(Sheets("A").Range("I:I"), Sheets("B").Cells(X, 3)) > 0 Then
        Set BUL = Sheets("A").Range("I:I").Find(Sheets("B").Cells(X, 3), LookAt:=xlWhole)
        If Not BUL Is Nothing Then
        Adres = BUL.Address
        Do
        If Sheets("A").Range("L" & BUL.Row) = "" Then
        Say = Say + 1
        Sheets("A").Range("F" & BUL.Row) = Sheets("B").Cells(X, 1)
        Sheets("A").Range("G" & BUL.Row) = Sheets("B").Cells(X, 2)
        Sheets("A").Range("L" & BUL.Row) = "X"
        End If
        If Say > 0 Then GoTo Devam
        Set BUL = Sheets("A").Range("I:I").FindNext(BUL)
        Loop While Not BUL Is Nothing And BUL.Address <> Adres
        End If
    ElseIf WorksheetFunction.CountIf(Sheets("A").Range("K:K"), Sheets("B").Cells(X, 3)) > 0 Then
        Set BUL = Sheets("A").Range("K:K").Find(Sheets("B").Cells(X, 3), LookAt:=xlWhole)
        If Not BUL Is Nothing Then
        Adres = BUL.Address
        Do
        If Sheets("A").Range("L" & BUL.Row) = "" Then
        Say = Say + 1
        Sheets("A").Range("F" & BUL.Row) = Sheets("B").Cells(X, 1)
        Sheets("A").Range("G" & BUL.Row) = Sheets("B").Cells(X, 2)
        Sheets("A").Range("L" & BUL.Row) = "X"
        End If
        If Say > 0 Then GoTo Devam
        Set BUL = Sheets("A").Range("K:K").FindNext(BUL)
        Loop While Not BUL Is Nothing And BUL.Address <> Adres
        End If
    End If
Devam:
    Say = 0
    Set BUL = Nothing
    Next
    Sheets("A").Range("L2:L65536").ClearContents
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[ANTALYA 01]

H

Merhabalar

Tam istediğim gibi bir kod olmuş fakat sizinde dediğinz gibi mükerrer rakamlarda doğru vermiyor.
Mesela 30 Tl de B sayfasında Hem Bülent te 30 var hemde tuba da böyle olunca A sayfasında 30 ların karşısına mükerrerlerin 2.sinede makro bittiğinde Bülenti getiriyor Doğrusu A sayfasında Aşağıdaki gibi olması gerekiyor.
3140007 BÜLENT 30
3030188 TUBA 30
1010014 AKIN 75
3030166 MEHMET 75

Olmuyorsa şöyle bir yolda izleyebiliriz diye düşünüyorum.B sayfasında bir makro Mükerrerlerin yan hücresine bir rakam bir işaret koyarak Yukarıdaki sonuçlara ulaşabiliriz.

 

[Korhan Ayhan]

Selamlar,

Üstteki mesajımdaki kodu güncelledim. İncelermisiniz.

 

[ANTALYA 01]

K

Merhaba

Tam istediğim gibi olmuş Allah razı olsun.Fakat bir şey daha sormak istiyorum.B Sayfasındaki ABC Sütunundaki veriler Örnek HIJ Sütunlarında olsa kodun neresini değiştirmem gerekiyor.

 

[Korhan Ayhan]

Selamlar,

Bu durumda kod aşağıdaki şekilde olacaktır. Değişiklik yapılan kısımlar kırmızı renkle belirtilmiştir.

Option Explicit
 
Sub RAKAM_EŞLEŞTİR()
    Dim X As Long, BUL As Range, Adres As String, Say As Integer
    Sheets("A").Range("G2:G65536,L2:L65536").ClearContents
    For X = 2 To Sheets("B").Range("[COLOR=red]J[/COLOR]65536").End(3).Row
    If WorksheetFunction.CountIf(Sheets("A").Range("I:I"), Sheets("B").Cells(X, [COLOR=red]10[/COLOR])) > 0 Then
        Set BUL = Sheets("A").Range("I:I").Find(Sheets("B").Cells(X, [COLOR=red]10[/COLOR]), LookAt:=xlWhole)
        If Not BUL Is Nothing Then
        Adres = BUL.Address
        Do
        If Sheets("A").Range("L" & BUL.Row) = "" Then
        Say = Say + 1
        Sheets("A").Range("F" & BUL.Row) = Sheets("B").Cells(X, [COLOR=red]8[/COLOR])
        Sheets("A").Range("G" & BUL.Row) = Sheets("B").Cells(X, [COLOR=red]9[/COLOR])
        Sheets("A").Range("L" & BUL.Row) = "X"
        End If
        If Say > 0 Then GoTo Devam
        Set BUL = Sheets("A").Range("I:I").FindNext(BUL)
        Loop While Not BUL Is Nothing And BUL.Address <> Adres
        End If
    ElseIf WorksheetFunction.CountIf(Sheets("A").Range("K:K"), Sheets("B").Cells(X, [COLOR=red]10[/COLOR])) > 0 Then
        Set BUL = Sheets("A").Range("K:K").Find(Sheets("B").Cells(X, [COLOR=red]10[/COLOR]), LookAt:=xlWhole)
        If Not BUL Is Nothing Then
        Adres = BUL.Address
        Do
        If Sheets("A").Range("L" & BUL.Row) = "" Then
        Say = Say + 1
        Sheets("A").Range("F" & BUL.Row) = Sheets("B").Cells(X, [COLOR=red]8[/COLOR])
        Sheets("A").Range("G" & BUL.Row) = Sheets("B").Cells(X, [COLOR=red]9[/COLOR])
        Sheets("A").Range("L" & BUL.Row) = "X"
        End If
        If Say > 0 Then GoTo Devam
        Set BUL = Sheets("A").Range("K:K").FindNext(BUL)
        Loop While Not BUL Is Nothing And BUL.Address <> Adres
        End If
    End If
Devam:
    Say = 0
    Set BUL = Nothing
    Next
    Sheets("A").Range("L2:L65536").ClearContents
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub