طلب مساعدة برمجية لحذف قيم متكررة واضافة قيم ناقصة

[حسين بلال]

السلام عليكم ورحمة الله وبركاته

 

 

أقوم بتحليل كشوف حسابات بنكية لعملاء شركتي مما يستلزمني استخدام المتوسط اليومي لارصدة حساباتهم. الطريقة اليدوية لفعل ذلك هو بأني ادخل الحركات اليومية للحساب,

 

 

من ثم, اقوم بحذف الحركات المتعددة في نفس اليوم ( ابقي فقط آخر حركة في كل يوم ) وبالتالي اليوم الذي فيه حركة واحدة, لا احذف منه شيئاً )

 

 

وأخيراً اقوم بادخال الناقص من الأيام. لهذه الحركات المضافة, الكود سيكون 33 ( احتاجه لعمليات تحليل أخرى ) أما الرصيد فيكون رصيد اليوم السابق

 

 

أرجو مساعدتي بكود برمجي يقوم بهذه العملية تلقائياً علماً ان عدد الأعمدة وتصميمها سيكون دائماً ثابت لكن عدد الحركات هو المتغير.

تم تعديل فبراير 5, 2014 بواسطه حسين بلال

[حسين بلال]

للأعلى رجاءاً

[حسين بلال]

تم الحل والحمد لله. أورد الحل للإفادة. جزاكم الله خيراً

 

 

الحل الأول: ( الأسرع والأفضل بنظري )

Sub hbsqn()
Dim i As Long
Dim x As Integer
Application.ScreenUpdating = False
For i = Range("A" & Rows.count).End(3)(1).Row To 2 Step -1
    If Range("A" & i).Value = Range("A" & i - 1).Value Then
        Range("A" & i - 1).EntireRow.Delete
    End If
Next i
x = 9
Do Until x = 0
Range("A" & Rows.count).End(3)(0).Select
Do Until ActiveCell.Row = 1
    If ActiveCell.Value + 1 <> ActiveCell.Offset(1).Value Then
        ActiveCell.Offset(1).EntireRow.Insert
        ActiveCell.Offset(1).Value = ActiveCell.Value + 1
        ActiveCell.Offset(1, 1).Value = 33
        ActiveCell.Offset(1, 2).Value = ""
        ActiveCell.Offset(1, 3).Value = ActiveCell.Offset(, 3).Value
    End If
    ActiveCell.Offset(-1).Select
Loop
x = x - 1
Loop
Application.ScreenUpdating = True
End Sub

الحل الثاني:

Sub FormatClosingBalance()
Dim rng As Range
Dim i As Long


Set rng = Selection
rng.Copy
rng.PasteSpecial xlPasteValues


For i = rng.Rows.Count To 2 Step -1
    Select Case rng(i - 1, 1)
        Case rng(i, 1)
            Rows(i - 1).Delete
        Case Is = rng(i, 1) - 1
            'Do nothing here
        Case Is < rng(i, 1) - 1
            Rows(i).Insert
            Cells(i, 1).Value = rng(i + 1, 1) - 1
            Cells(i, 2).Value = 33
            Cells(i, 4).Value = rng(i - 1, 4)
            i = i + 1
        Case Else
            'Headers dont match row 2
    End Select
Next i


rng.Columns(3).Delete 'Delete this if you don't need to delete the Amount Column


End Sub

[عبدالله باقشير]

اخي الفاضل حسين بلال