تقسيم عمود به مبالغ مالية بالموجب والسالب

[figo82eg]

ارجو من الاخوة الكرام المساعدة حيث  لدى ملف اكسل به مديونية الاف العملاء وارصدتهم لدى بالموجب والسالب ومصفره .

ما اريد ان اقوم بتقسيم هذا العمود الى ثلاثة اعمدة عمود دائن ويتم توزيع القيم السالبة به وعمود مدين ويتم توزيع القيم الموجبة به وعمود ثالث منتهى به الارصدة المساوية لصفر.

فهل استطيع فعل ذلك مرة واحدة

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

قمت بعمل مثال لك بفصل الحالات الثلاتة كما طلبت

 الكود

Sub FilterValues()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1")
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row

    ws.Range("G2:H" & ws.Cells(ws.Rows.Count, "G").End(xlUp).Row).ClearContents
    ws.Range("I2:J" & ws.Cells(ws.Rows.Count, "I").End(xlUp).Row).ClearContents
    ws.Range("K2:L" & ws.Cells(ws.Rows.Count, "K").End(xlUp).Row).ClearContents

    Dim negArr() As Variant
    Dim posArr() As Variant
    Dim zeroArr() As Variant
    Dim i As Long, negCount As Long, posCount As Long, zeroCount As Long

    Dim dataRange As Range
    Set dataRange = ws.Range("B2:C" & lastRow)
    Dim dataArr As Variant
    dataArr = dataRange.Value

    ReDim negArr(1 To UBound(dataArr, 1), 1 To 2)
    ReDim posArr(1 To UBound(dataArr, 1), 1 To 2)
    ReDim zeroArr(1 To UBound(dataArr, 1), 1 To 2)

    negCount = 0
    posCount = 0
    zeroCount = 0

    For i = 1 To UBound(dataArr, 1)
        Select Case dataArr(i, 2)
            Case Is < 0
                negCount = negCount + 1
                negArr(negCount, 1) = dataArr(i, 1)
                negArr(negCount, 2) = dataArr(i, 2)
            Case Is > 0
                posCount = posCount + 1
                posArr(posCount, 1) = dataArr(i, 1)
                posArr(posCount, 2) = dataArr(i, 2)
            Case Else
                zeroCount = zeroCount + 1
                zeroArr(zeroCount, 1) = dataArr(i, 1)
                zeroArr(zeroCount, 2) = dataArr(i, 2)
        End Select
    Next i

    ws.Range("G2").Resize(negCount, 2).Value = Application.Index(negArr, Evaluate("ROW(1:" & negCount & ")"), Array(1, 2))
    ws.Range("I2").Resize(posCount, 2).Value = Application.Index(posArr, Evaluate("ROW(1:" & posCount & ")"), Array(1, 2))
    ws.Range("K2").Resize(zeroCount, 2).Value = Application.Index(zeroArr, Evaluate("ROW(1:" & zeroCount & ")"), Array(1, 2))
End Sub

الملف

فصل الدائن والمدين والصفرية الى اعمدة جديدة.xlsb

تم تعديل أكتوبر 23, 2024 بواسطه عبدالله بشير عبدالله

[figo82eg]

بارك الله فيك اخى الكريم وجعل علمك فى ميزان حسناتك