tek satırı sütuna çevirme

[igultekin2000]

iyi günler;
programla tek satır olarak ayrıştırılan ekstreyi excelde sütunlu haline çevirmenin kolay yolu var mıdır? Teşekkürler

 

[askm]

Biraz uzun yol oldu ama çalışıyor gibi.

Sub ASKM_Sutuna_Cevir()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("İŞLENMİŞ")
Dim son1 As Long, son2 As Long
Dim Tarih, Valör As String, Aciklama As String, ITutar As String, ISaat As String
Dim veri As String
Dim Bakiye As String, DekontNo As String
Dim harfsira As Integer
Application.ScreenUpdating = False
son1 = s1.Range("A" & Rows.Count).End(3).Row
son2 = s2.Range("A" & Rows.Count).End(3).Row + 1
For I = 24 To son1
    If s1.Cells(I, 1) <> Empty Then
        veri = s1.Cells(I, 1)
        Tarih = Trim(Left(veri, 14))
        s2.Cells(son2, 1) = Tarih
        veri = Trim(Mid(veri, 15, Len(veri)))
        Valör = Mid(veri, 1, 11)
        s2.Cells(son2, 2) = Valör
        veri = Trim(Mid(veri, 12, Len(veri)))
        DekontNo = Right(veri, 13)
        s2.Cells(son2, 7) = DekontNo
        veri = Trim(Mid(veri, 1, Len(veri) - 13))
        Sira = InStr(Len(veri) - 10, veri, " ")
        Bakiye = Mid(veri, Sira + 1, Len(veri))
        s2.Cells(son2, 6) = Bakiye
        veri = Trim(Mid(veri, 1, Sira))
        ISaat = Right(veri, 10)
        s2.Cells(son2, 5) = ISaat
        veri = Trim(Mid(veri, 1, Len(veri) - 10))
        Sira = InStr(Len(veri) - 10, veri, " ")
        ITutar = Mid(veri, Sira + 1, Len(veri))
        s2.Cells(son2, 4) = ITutar
        veri = Trim(Mid(veri, 1, Sira))
        Aciklama = veri
        s2.Cells(son2, 3) = Aciklama
        son2 = son2 + 1
    End If
Next I
Application.ScreenUpdating = True
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub

 

[igultekin2000]

Biraz uzun yol oldu ama çalışıyor gibi.

Sub ASKM_Sutuna_Cevir()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("İŞLENMİŞ")
Dim son1 As Long, son2 As Long
Dim Tarih, Valör As String, Aciklama As String, ITutar As String, ISaat As String
Dim veri As String
Dim Bakiye As String, DekontNo As String
Dim harfsira As Integer
Application.ScreenUpdating = False
son1 = s1.Range("A" & Rows.Count).End(3).Row
son2 = s2.Range("A" & Rows.Count).End(3).Row + 1
For I = 24 To son1
    If s1.Cells(I, 1) <> Empty Then
        veri = s1.Cells(I, 1)
        Tarih = Trim(Left(veri, 14))
        s2.Cells(son2, 1) = Tarih
        veri = Trim(Mid(veri, 15, Len(veri)))
        Valör = Mid(veri, 1, 11)
        s2.Cells(son2, 2) = Valör
        veri = Trim(Mid(veri, 12, Len(veri)))
        DekontNo = Right(veri, 13)
        s2.Cells(son2, 7) = DekontNo
        veri = Trim(Mid(veri, 1, Len(veri) - 13))
        Sira = InStr(Len(veri) - 10, veri, " ")
        Bakiye = Mid(veri, Sira + 1, Len(veri))
        s2.Cells(son2, 6) = Bakiye
        veri = Trim(Mid(veri, 1, Sira))
        ISaat = Right(veri, 10)
        s2.Cells(son2, 5) = ISaat
        veri = Trim(Mid(veri, 1, Len(veri) - 10))
        Sira = InStr(Len(veri) - 10, veri, " ")
        ITutar = Mid(veri, Sira + 1, Len(veri))
        s2.Cells(son2, 4) = ITutar
        veri = Trim(Mid(veri, 1, Sira))
        Aciklama = veri
        s2.Cells(son2, 3) = Aciklama
        son2 = son2 + 1
    End If
Next I
Application.ScreenUpdating = True
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub

sorunsuz ve verimli çalışıyor, elinize sağlık , çok teşekkür ederim. iyi çalışmalar.

 

[veyselemre]

Sub Test()
    Sheets("Sayfa1").Copy Before:=Sheets(1)
    Range("A1:A19,A22").ClearContents
    Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
                               FieldInfo:=Array(Array(0, 4), Array(12, 4), Array(24, 2), Array(102, 1), Array(122, 1), _
                                                Array(135, 1), Array(151, 2)), TrailingMinusNumbers:=True
    Columns.AutoFit
End Sub

Sub Test2()
    Sheets("Sayfa1").Copy Before:=Sheets(1)
    Range("A1:A19,A22").ClearContents
    Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
                               FieldInfo:=Array(Array(0, 4), Array(12, 4), Array(24, 2), Array(102, 1), Array(122, 9), _
                                                Array(135, 1), Array(151, 2)), TrailingMinusNumbers:=True
    Columns.AutoFit
End Sub

 

[igultekin2000]

Sub Test()
    Sheets("Sayfa1").Copy Before:=Sheets(1)
    Range("A1:A19,A22").ClearContents
    Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
                               FieldInfo:=Array(Array(0, 4), Array(12, 4), Array(24, 2), Array(102, 1), Array(122, 1), _
                                                Array(135, 1), Array(151, 2)), TrailingMinusNumbers:=True
    Columns.AutoFit
End Sub

Sub Test2()
    Sheets("Sayfa1").Copy Before:=Sheets(1)
    Range("A1:A19,A22").ClearContents
    Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
                               FieldInfo:=Array(Array(0, 4), Array(12, 4), Array(24, 2), Array(102, 1), Array(122, 9), _
                                                Array(135, 1), Array(151, 2)), TrailingMinusNumbers:=True
    Columns.AutoFit
End Sub

Teşekkürler
ikisi kotta sorunsuz çalışıyor, iyi çalışmala.