Tutarların yanındaki sütunlara aktarılması hk.

[1903emre34@gmail.com]

Merhaba,

A sütündaki tutarları sırasıyla "B" ve "C"' e aktarmak istiyorum, kodu çalıştırdığım zaman belli sıraya kadar yanlara aktarıyor, nasıl değişiklik yapabiliriz. istenen sayfa2'de yapılmıştır.

 

[Orion1]

Merhaba,

A sütündaki tutarları sırasıyla "B" ve "C"' e aktarmak istiyorum, kodu çalıştırdığım zaman belli sıraya kadar yanlara aktarıyor, nasıl değişiklik yapabiliriz. istenen sayfa2'de yapılmıştır.

Buyurun.

Sub aktar59()
Dim a, i As Long, sonsat As Long
Range("B:C").ClearContents
sonsat = Cells(Rows.Count, "A").End(xlUp).Row
For i = 3 To sonsat
    a = Split(Cells(i, "A").Value)
    Cells(i, "C").Value = a(UBound(a) - 1)
    Cells(i, "B").Value = a(UBound(a) - 2)
Next
End Sub

 

[askm]

Değerlerinin örneğinizdeki gibi her zaman nokta boşluk ile rakam ile mi başlıyor?

 

[Erdem Akdemir]

Merhaba,

Veriler aynı standartta ise aşağıdaki formülü kullanabilirsiniz. Formülü herhangi bir hücreye yapıştırın ve sağa doğru'da kopyalayın.

=EĞERHATA(İNDİS(--KIRP(PARÇAAL(YERİNEKOY(KIRP($A3);" ";YİNELE(" ";255));SATIR($1:$99)*255;255));3+SÜTUN(A1)-1);"")

 

[1903emre34@gmail.com]

İliginiz için teşekkürler ekteki dosyada oldu ama original dosyada hata verdi dosyanın bir kısmın yüklerim örnekler boşluk ve rakam ile başlıyor

 

[1903emre34@gmail.com]

1 nolu mesajdaki dosya güncelledim.

 

[Erdem Akdemir]

Merhaba,

Hata vermesinin sebebi 100.00,50 şeklinde olan sayı formatı. Bunu düzeltirseniz formül çalışır.
Bende muhasebeciyim, geçici vergi gelir tablosuna benziyor. Bununla ilgili kontrol çalışması mı hazırlıyorsunuz.
Kendime hazırladığım bu konu ile ilgili çalışmalarım var. Eğer istediğinizi paylaşırsanız daha çok faydam dokunur.

 

[Ziynettin]

Merhaba,

Bu şekilde deneyiniz.

Sub ayır()
a = Range("A4:A" & Cells(Rows.Count, 1).End(3).Row).Value
ReDim b(1 To UBound(a), 1 To 2)

For i = 1 To UBound(a)
    say = say + 1
    If a(i, 1) <> "" Then
        deg = Split(a(i, 1), " ")
        If IsNumeric(deg(UBound(deg) - 2)) Then b(say, 1) = CDbl(deg(UBound(deg) - 2))
        If IsNumeric(deg(UBound(deg) - 1)) Then b(say, 2) = CDbl(deg(UBound(deg) - 1))
    End If
Next i

Range("B4:C" & Rows.Count).ClearContents
If say > 0 Then [B4].Resize(say, 2) = b
MsgBox "İşlem tamam...", vbInformation
End Sub

 

[1903emre34@gmail.com]

Ziynettin hocam, teşekkürler, çalışıyor, tutarları yandaki sütunlara aktarırken ham haliyle kalması için değişiklik yapabiliriz

Sn.Kuvari teşekkürler,

 

[Ziynettin]

A sütunu verileri [B,C,D] sütunlarına ayırır.

Sub ayir_1()
a = Range("A4:B" & Cells(Rows.Count, 1).End(3).Row).Value
ReDim b(1 To UBound(a), 1 To 3)
On Error Resume Next
For i = 1 To UBound(a)
    say = say + 1
    If a(i, 1) <> "" Then
        deg = Split(a(i, 1), " ")
        If IsNumeric(deg(UBound(deg) - 2)) Then b(say, 2) = Format(deg(UBound(deg) - 2), "#,##0.00")
        If IsNumeric(deg(UBound(deg) - 1)) Then b(say, 3) = Format(deg(UBound(deg) - 1), "#,##0.00")
        sayac = InStrRev(Trim(a(i, 1)), b(say, 2))
        b(say, 1) = Left(a(i, 1), sayac - 1)
    End If
Next i
Range("B4:C" & Rows.Count).ClearContents
If say > 0 Then [B4].Resize(say, 3) = b
MsgBox "İşlem tamam...", vbInformation
End Sub

 

[Orion1]

Benim 2# nolu mesajdaki verdiğim kodlar olmadımı?

 

[1903emre34@gmail.com]

Hata verdi.

 

[Orion1]

Hata verdi.

Buyurun.

Sub Düğme2_Tıklat()
Dim a, i As Long, sonsat As Long
Range("B:C").ClearContents
sonsat = Cells(Rows.Count, "A").End(xlUp).Row
For i = 4 To sonsat
    If Cells(i, "A").Value <> "" Then
        a = Split(Cells(i, "A").Value)
        Cells(i, "C").Value = a(UBound(a) - 1)
        Cells(i, "B").Value = a(UBound(a) - 2)
    End If
Next
MsgBox "BİTTİ"
End Sub