Muhasebe hesap kodu güncellemesi/ Makro ya da değiştir formülü ile..

[ckaval89]

Selam üstadlar,

Ekte bulunan çalışmada iki adet sheet var, 1 ve 2 numara adı altında.

1 numarada bulunan verilerin bir kopyası 2 numarada bulunan sarı boyalı taraf ile aynı.

Amacım;
*Sarı boyalı tarafta belirtilen "code"ları mavi boyalı tarafta bulunan "code" ler ile değiştirilmesi ama bunu 1 numaranın içinde yapılması

*Sarıda boş satır varsa Mavi tarafta veri varsa onun yeni satır olarak sarıya ve 1 numaraya eklenmesi,

* Mavide boş satır varsa o satırın sarıda ve 1 numara da silinmesi .

Umarım tarif edebilmişimdir...

 

[Ömer BARAN]

Merhaba.

Aşağıdaki kodları dener misiniz?
-- İlk kod hesap kodu değişikliği işlemini (amacım dediğiniz ilk cümlenin karşılığı)
-- İkincisi ise diğer istediklerinizi yapar.
.

[B][COLOR="blue"]Sub HESAP_USTUNE_YAZ()[/COLOR][/B]
Set s1 = Sheets("1"): Set s2 = Sheets("2")
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
s1son = s1.Cells(Rows.Count, 1).End(3).Row
On Error GoTo 10
For sat1 = 5 To s1son
    If s1.Cells(sat1, "F") <> "" Then
        If WorksheetFunction.CountIf(s2.[A:A], s1.Cells(sat1, "F")) > 0 Then
            s2sat = WorksheetFunction.Match(s1.Cells(sat1, "F"), s2.[A:A], 0)
            If s2.Cells(s2sat, "I") <> "" And s2.Cells(s2sat, "I") <> s1.Cells(sat1, "F") Then
                say = say + 1: s1.Cells(sat1, "F") = s2.Cells(s2sat, "I")
            End If
        End If
    End If
10: Next
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
If say = Empty Then
    MsgBox "Değiştirilecek herhangi bir HESAP KODU bulunamadı.", vbInformation, "..:: Ömer BARAN ::.."
    Exit Sub
End If
If say > 0 Then _
    MsgBox say & " adet Hesap Kodu değiştirildi.", vbInformation, "..:: Ömer BARAN ::.."
[B][COLOR="Blue"]End Sub[/COLOR][/B]

[B][COLOR="Blue"]Sub HESAP_KODU_GUNCELLE_EKLE_SIL()[/COLOR][/B]
Set s1 = Sheets("1"): Set s2 = Sheets("2")
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
s2son = s2.Cells(Rows.Count, 1).End(3).Row
On Error GoTo 10
For sat2 = s2son To 3 Step -1
    If s2.Cells(sat2, "A") = "" And s2.Cells(sat2, "I") <> "" Then
        s2.Range("I" & sat2 & ":N" & sat2).Copy s2.Cells(sat2, 1)
        ss = WorksheetFunction.Match(s2.Cells(sat2, "I"), s1.[A:A], 1)
        s2.Range("I" & sat2 & ":N" & sat2).Copy
        s1.Range("F" & ss + 1 & ":K" & ss + 1).Insert Shift:=xlDown
        eklenen = eklenen + 1
    ElseIf s2.Cells(sat2, "I") = "" And s2.Cells(sat2, "A") <> "" Then
        s2.Range("A" & sat2 & ":O" & sat2).Delete Shift:=xlUp
        silinen = silinen + 1
    ElseIf s2.Cells(sat2, "I") = "" And s2.Cells(sat2, "A") = "" Then
        s2.Range("A" & sat2 & ":N" & sat2).Delete Shift:=xlUp
        bos = bos + 1
    End If
10: Next
        Application.CutCopyMode = False
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
If eklenen > 0 Then ekle = "-- 1 isimli sayfada F:K sütun aralığına " & _
    eklenen & " adet satır eklendi, 2 isimli sayfada da A:F sütun aralığındaki satırlarına yazıldı."
If silinen > 0 Then sil = "-- 2 isimli sayfada A:F sütun aralığından " & silinen & " adet satır silindi."
If bos > 0 Then boss = "-- 2 isimli sayfada, A;F ve I:N sütun aralıkları tamammen boş olan " & bos & " adet satır silindi."
If silinen = Empty And eklenen = Empty Then
    MsgBox "Herhangi bir işlem yapılmadı."
    Exit Sub
End If
MsgBox "İşlem tamamlandı." & vbLf & _
        ekle & vbLf & sil & vbLf & boss, vbInformation, "..:: Ömer BARAN ::.."
[B][COLOR="blue"]End Sub[/COLOR][/B]

 

[ckaval89]

harika olmuş, elinize emeğinize sağlık.

 

[Ömer BARAN]

Kolay gelsin.