Tablo1 den Tablo2 nasıl elde edilir?

[Tevfik_Kursun]

Merhaba Arkadaşlar,
Ekli dosyadan Tablo1 den Tablo2 nasıl elde edilir?
Ekli_Dosya
Saygılarımla

 

[DoğanD]

Merhaba,

Sorunuzu sayıların bulunduğu adresleri bulmak olarak anladım, yanlış yorumladıysam düzeltin lütfen. Ona göre de bir çözüm bulduğuma inanıyorum. Aşağıdaki kodları dener misiniz?

Sub deneme()
Range("W1:AC20").ClearContents
sut = 23
For i = 1 To 4
    For y = 3 To 10
    If Cells(y, i) = "" Then GoTo atla
        If WorksheetFunction.CountIf(Range("W1:Ac1"), Cells(y, i)) = 0 Then
        Cells(1, sut) = Cells(y, i)
        sutb = sut
        sut = sut + 1
        Else
        sutb = WorksheetFunction.Match(Cells(y, i), Range("W1:AG1"), 0) + 22
        End If
           sat = Cells(Rows.Count, sutb).End(3).Row + 1
    Cells(sat, sutb) = WorksheetFunction.Substitute(Cells(y, i).Address, "$", "")
atla:
    Next y
Next i

 

[Tevfik_Kursun]

Merhaba Arkadaşım,
İlginize teşekkür ederim. Ama Tablo1 deki 1 ler Tablo2 de 1 sütununun altında Tablo1 de hangi harfin altında ise olmasını istiyorum.
Saygılarımla

 

[muygun]

Merhaba;
Alternatif:
Eki deneyin.
İyi çalışmalar.

 

[DoğanD]

Tekrar Merhaba,

Kodları buna göre revize ettim.

Sub deneme()
Range("W1:AC20").ClearContents
sut = 23
For i = 1 To 4
    For y = 3 To 10
    If Cells(y, i) = "" Then GoTo atla
        If WorksheetFunction.CountIf(Range("W1:Ac1"), Cells(y, i)) = 0 Then
        Cells(1, sut) = Cells(y, i)
        sutb = sut
        sut = sut + 1
        Else
        sutb = WorksheetFunction.Match(Cells(y, i), Range("W1:AG1"), 0) + 22
        End If
           sat = Cells(Rows.Count, sutb).End(3).Row + 1
    Cells(sat, sutb) = Left(WorksheetFunction.Substitute(Cells(y, i).Address, "$", ""), 1) & Cells(1, sutb)
atla:
    Next y
Next i
End Sub

 

[Tevfik_Kursun]

Sayın Muygun ve Sayın DoğanD,
Her ikinize de teşekkür ederim.
Saygılarımla