Aktarılan verileri satır yerine sırasıyla sütuna aktarma

[Erdinç FIRTINA]

Değerli Forum üyeleri,

Sayın Korhan AYHAN'ın hazırlamış olduğu kodlarla satıra göre aktarma yapılabiliyor.
Aynı şekilde tablodan aktarılan veriler sırasıyla sütuna aktarılabilir mi?
Yardımlarınız için şimdiden teşekkürler!!!

Dosya ektedir.

KODLAR
Dim ALAN As Range
Set S1 = Sheets("Sayfa1")
Set S2 = Sheets("Sayfa2")
SATIR = 2
S1.Select
[C2:AA65536].ClearContents
If TextBox1 = "" Then
MsgBox "LÜTFEN ARAMAK İSTEDİĞİNİZ VERİYİ GİRİNİZ !", vbExclamation, "DİKKAT !"
TextBox1.SetFocus
Exit Sub
End If
For Each ALAN In S2.Range("D7:AA31").SpecialCells(xlCellTypeConstants, 23)
If Evaluate("=UPPER(""" & ALAN.Value & """)") = Evaluate("=UPPER(""" & TextBox1.Value & """)") Then
S1.Cells(SATIR, 3) = S2.Cells(ALAN.Row, 3)
S1.Cells(SATIR, 4) = ALAN.Value
S1.Cells(SATIR, 5) = ALAN.Offset(0, 1).Value
S1.Cells(SATIR, 6) = ALAN.Offset(0, 2).Value
SATIR = SATIR + 1
End If
Next
If SATIR > 2 Then
MsgBox "AKTARMA İŞLEMİ TAMAMLANMIŞTIR.", vbInformation
Else
MsgBox "ARANAN KAYIT BULUNAMAMIŞTIR.", vbCritical
End If

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Private Sub CommandButton1_Click()
    Dim ALAN As Range
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    SATIR = 2
    SÜTUN = 8
    S1.Select
    [H2:IV65536].ClearContents
    If TextBox1 = "" Then
    MsgBox "LÜTFEN ARAMAK İSTEDİĞİNİZ VERİYİ GİRİNİZ !", vbExclamation, "DİKKAT !"
    TextBox1.SetFocus
    Exit Sub
    End If
    For Each ALAN In S2.Range("D7:AA31").SpecialCells(xlCellTypeConstants, 23)
    If Evaluate("=UPPER(""" & ALAN.Value & """)") = Evaluate("=UPPER(""" & TextBox1.Value & """)") Then
    S1.Cells(SATIR, SÜTUN) = S2.Cells(ALAN.Row, 3)
    S1.Cells(SATIR, SÜTUN + 1) = ALAN.Value
    S1.Cells(SATIR, SÜTUN + 2) = ALAN.Offset(0, 1).Value
    S1.Cells(SATIR, SÜTUN + 3) = ALAN.Offset(0, 2).Value
    SÜTUN = SÜTUN + 4
    End If
    Next
    If WorksheetFunction.CountA(Rows(2)) > 0 Then
    MsgBox "AKTARMA İŞLEMİ TAMAMLANMIŞTIR.", vbInformation
    Else
    MsgBox "ARANAN KAYIT BULUNAMAMIŞTIR.", vbCritical
    End If
End Sub

 

[Erdinç FIRTINA]

Sayın Korhan Ayhan,
Her şey için çok teşekkürler.