Sütündakileri yer değiştirmek

[bjk55]

Örnek excelde yolladığım gibi Kırmızı İle İşaretlediğim Sütunda Yazılan Rakamların Yeşil Sutuna Yazılmasını Yazıldıktan Sonra Yeşil Sütundan Sarı Sütün Çıkartılıp Kırmızı Sütüna Yazılmasını İstiyorum. bunun için nasıl bir makro kodu oluşturabilirim. Şimdiden Teşekkür ederim

 

[kulomer46]

Merhaba

Dosyanız Ek' tedir.

Selamlar...

 

[bjk55]

Merhaba

Dosyanız Ek' tedir.

Selamlar...

Çok teşekkür ederim

 

[kulomer46]

Çok teşekkür ederim

Selamlar...

 

[bjk55]

şimdi tekrar denedim 600.01.01 de kiler kopyalanıyor ya bazen bu kodlar değişebiliyor direk 600. ile başlayanlar kopyalansın makro kodlarını düzelttim ancak olmadı

Sub Aktar()
'09.01.2020 13:54

c = MsgBox("Hesapla çalıştırılacak", vbOKCancel)
If c = vbCancel Then Exit Sub

sonb = Cells(Rows.Count, 2).End(3).Row

For i = 2 To sonb

If Trim(Cells(i, 2)) = "600." Then

If Trim(Cells(i + 1, 2)) <> "600." Then

If Trim(Cells(i + 2, 2)) <> "600." Then


Cells(i + 1, 7) = Cells(i, 8)
Cells(i, 8) = Cells(i + 1, 7) - Cells(i + 2, 8)


End If

End If

End If

Next


End Sub

 

[kulomer46]

Tekrar Merhaba

Kodlar şu şekilde düzenlenmelidir.

Kolay Gelsin...

Sub Aktar()
'09.01.2020    13:54

c = MsgBox("Hesapla çalıştırılacak", vbOKCancel)
If c = vbCancel Then Exit Sub
sonb = Cells(Rows.Count, 2).End(3).Row

For i = 2 To sonb 
 
    If Left(Trim(Cells(i, 2)), 4) = "600." Then      
        If Left(Trim(Cells(i + 1, 2)), 4) <> "600." Then      
            If Left(Trim(Cells(i + 2, 2)), 4) <> "600." Then  

                    Cells(i + 1, 7) = Cells(i, 8)
                    Cells(i, 8) = Cells(i + 1, 7) - Cells(i + 2, 8) 

            End If          
        End If      
    End If

Next  
  
End Sub

 

[bjk55]

Tekrar Merhaba

Kodlar şu şekilde düzenlenmelidir.

Kolay Gelsin...

Sub Aktar()
'09.01.2020    13:54

c = MsgBox("Hesapla çalıştırılacak", vbOKCancel)
If c = vbCancel Then Exit Sub
sonb = Cells(Rows.Count, 2).End(3).Row

For i = 2 To sonb

    If Left(Trim(Cells(i, 2)), 4) = "600." Then     
        If Left(Trim(Cells(i + 1, 2)), 4) <> "600." Then     
            If Left(Trim(Cells(i + 2, 2)), 4) <> "600." Then 

                    Cells(i + 1, 7) = Cells(i, 8)
                    Cells(i, 8) = Cells(i + 1, 7) - Cells(i + 2, 8)

            End If         
        End If     
    End If

Next 
 
End Sub

Tekrar Merhaba, Makro ile hesaplamayı nasıl yapabiliriz örnek gösterebilir misiniz? Teşekkür ederim