Makro Kodundaki Eksiklik

[cavanoos]

Merhaba arkadaşlar;

Ekli dosyamda butona tıkladığınızda Ekstre sayfasındaki butona tıkladığımda E sütunu oluşuyor.Örneğin E2 hücresi butona bastıktan sonra doluyor.Ama E3 hücresi dolmuyor.

Makro kodunda bir yazımı düzeltmek gerekiyor.Yardım edebilir misiniz ?

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

Sub bluess_devils()
Dim a As Range
Dim b As Range
Dim ex As Worksheet
Dim Adres As String
son = Sheets("Tanımlamalar").Range("A65536").End(xlUp).Row
For Each a In Sheets("Tanımlamalar").Range("B2:B" & son)
    Set b = Sheets("Ekstre").Range("B:B").Find(a, , xlValues, xlPart)
    If Not b Is Nothing Then
        Adres = b.Address
        Do
            b.Offset(0, 3) = a.Offset(0, -1)
            Set b = Sheets("Ekstre").Range("B:B").FindNext(b)
        Loop While Not b Is Nothing And b.Address <> Adres
    End If
Next a
MsgBox "İşlem tamamlandı.", vbInformation, "T A M A M"
End Sub

 

[Emir Hüseyin Çoban]

. . .

Sub KOD()
Application.ScreenUpdating = False

Dim S1 As Worksheet
Dim S2 As Worksheet
Set S1 = Sheets("Tanımlamalar")
Set S2 = Sheets("Ekstre")

S2.Range("e2:e65536").ClearContents
s1son = S1.[A65536].End(3).Row
s2son = S2.[B65536].End(3).Row

For a = 2 To s2son
For i = 2 To s1son
If S2.Cells(a, "B") Like "*" & S1.Cells(i, "B") & "*" Then
S2.Cells(a, "E") = S1.Cells(i, "A")
Else: End If
Next i
Next a


Set S1 = Nothing
Set S2 = Nothing
Application.ScreenUpdating = True
MsgBox " B İ T T İ "
End Sub

. . .

 

[cavanoos]

Arkadaşlar;

Teşekkür ederim.Sorunum çözülmüştür...

 

[assenucler]

Değerli üstadlarım;

Günaydınlar ve hayırlı işler.

Katkılarınız için teşekkür ederim.

Acaba, "Tanımlamalar" sayfasındaki tabloyu "liste" olarak adlandırsak,
"Ekstre" sayfası E sütununa isimler geldikten sonra, C sütununa anılan firmaların "hesap numarasını" getirmek için kodlara nasıl ekleme yapılması gerekli?

Yardımınız için önceden teşekkürler.

Sevgi ve saygılar.

 

[Emir Hüseyin Çoban]

. . .

Kodlardaki Sheets("Tanımlamalar") kısmını sayfa isminize göre değiştirin.

Korhan Bey' in kodları için aşağıdaki satırı ilave edin.

Do
b.Offset(0, 3) = a.Offset(0, -1)
[B][COLOR="Red"]b.Offset(0, 1) = a.Offset(0, 0)[/COLOR][/B]
Set b = Sheets("Ekstre").Range("B:B").FindNext(b)

. . .

Benim kodlarım için;

If S2.Cells(a, "B") Like "*" & S1.Cells(i, "B") & "*" Then
S2.Cells(a, "E") = S1.Cells(i, "A")
[B][COLOR="Red"]S2.Cells(a, "C") = S1.Cells(i, "B")
[/COLOR][/B]Else: End If
Next i

. . .

 

[assenucler]

Sayın Hüseyin Çoban,

Üstadım, zaman ayırarak verdiğiniz katkı için sağ olun var olun...

Sevgi ve saygılar.