سحب الرقم القومي والصافي فقط

[رجب مرسي]

معادلة او كود اذا وجد الرقم القومي وامامة الصافي ينسخهم مرة واحدة الي الاعمدة باللون الازرق اما اذاكان الصف فارغ او لا يوجد به رقم قومي لا ينسخ او ينقل اي شئ بل يحذف الصف

لا ينسخ الصفوف الفارغة او الصفوف التي لا تحتوي على قومي او صافي مع العلم ان الشيت متغير كل الشهر الصفوف تختلف من شهر الى شهر وهذا ملف للتوضيح فقط جزيتم الجنة

222222.xlsx

[محمد هشام.]

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

تفضل اخي ربما هدا ما تقصد 

Option Explicit
Sub Test()
Dim i&, F&, K&, R&, lastrow&
Dim Rng     As Variant
Dim Réf     As Variant
Dim DelRng  As Range

Dim sh As Worksheet: Set sh = Sheets("Sheet1")
lastrow = sh.Columns("A:F").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row

Application.ScreenUpdating = False

    sh.Range("E7:F" & lastrow).ClearContents
   
    Rng = sh.Range("A7:B" & lastrow).Value
    ReDim Réf(1 To UBound(Rng, 1), 1 To UBound(Rng, 2))
    F = 1
    For i = LBound(Rng, 1) To UBound(Rng, 1)
    
    If Rng(i, 1) <> "" And Rng(i, 1) <> "الصافي" And Rng(i, 2) <> "" Then
            For K = LBound(Rng, 2) To UBound(Rng, 2)
                Réf(F, K) = Rng(i, K)
            Next K
            F = F + 1
        End If
    
    Next i
sh.Range("E7").Resize(F - 1, UBound(Réf, 2)).Value = Réf

 With sh
    For R = lastrow To 7 Step -1
'حدف العناوين
'If .Cells(R, "A").Value = "" Or .Cells(R, "B").Value = "" Or .Cells(R, "A").Value = "الصافي" Then
        
If .Cells(R, "A").Value = Empty Or .Cells(R, "B").Value = Empty Then

            Set DelRng = .Range(.Cells(R, 1), .Cells(R, 2))
            DelRng.Delete Shift:=xlUp
        End If
    Next R
End With
   
Application.ScreenUpdating = True

End Sub

 

222222.xlsm

[محي الدين ابو البشر]

وعليكم السلام

خيار آخر

Sub Test()
    Dim a
    Dim i&
    Application.ScreenUpdating = False
    a = Cells(7, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row, 2)
    With CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            If a(i, 1) & a(i, 2) <> "" And a(i, 1) <> 0 And a(i, 2) <> "" And a(i, 1) <> "" And WorksheetFunction.IsNumber((a(i, 1))) Then
                If Not .exists(a(i, 1) & "|" & a(i, 2)) Then .Add a(i, 1) & "|" & a(i, 2), ""
            End If
        Next
        Cells(7, 5).Resize(.Count) = Application.Transpose(.keys)
        Application.DisplayAlerts = False
        Cells(7, 5).Resize(.Count).TextToColumns Destination:=Range("E7"), OtherChar:="|", FieldInfo:=Array(2, 1)
    End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

[محي الدين ابو البشر]

السلام عليكم 

وهذا خيار آخر

Sub test2()
    Dim a, b
    Dim i&, ii&
    a = Cells(7, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row, 2)
    ReDim b(0 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
        If a(i, 1) & a(i, 2) <> "" And a(i, 1) <> 0 And a(i, 2) <> "" And a(i, 1) <> 0 And _
                                                                                  WorksheetFunction.IsNumber((a(i, 1))) Then b(ii, 1) = i: ii = ii + 1
    Next
    Cells(7, 10).Resize(ii, 2) = Application.Index(a, b, Array(1, 2))
End Sub