تحويل الصفوف الى اعمدة واهمال الفراغات والبحث برقم فى عمود

[رضا على]

اريد البحث بطريقة معينة بدلاله رقم بعمود ويتم ادراج صفوف الرقم فى صورة غمود يكما هو موضح داخل الملف

فواتير.xlsm

[omar elhosseini]

شاهد المرفق اخي

فواتير.xlsm

[lionheart]

Sub Test()
    Dim a, w, ws As Worksheet, f As Boolean, i As Long, ii As Long, k As Long, m As Long
    Application.ScreenUpdating = False
        Set ws = ActiveSheet
        ws.Range("B20").CurrentRegion.Offset(2).ClearContents
        w = ws.Range("D20").Value
        If w = Empty Then MsgBox "Enter ID First", vbExclamation: Exit Sub
        a = ws.Range("A3:P" & ws.Cells(Rows.Count, 1).End(xlUp).Row).Value
        ReDim b(1 To UBound(a, 1) * 4, 1 To 5)
        For i = LBound(a) To UBound(a)
            If a(i, 4) = w Then
                k = k + 1
                b(k, 1) = a(i, 1)
                b(k, 2) = a(i, 2)
                m = 0
                For ii = 5 To 14 Step 3
                    If a(i, ii) <> Empty Then
                        f = True
                        b(k + m, 3) = a(i, ii)
                        b(k + m, 4) = a(i, ii + 1)
                        b(k + m, 5) = a(i, ii + 2)
                        m = m + 1
                    End If
                Next ii
                If m > 0 Then k = k + m - 1
                If f = False Then b(k, 1) = Empty: b(k, 2) = Empty: f = False: k = k - 1
            End If
        Next i
        If k > 0 Then ws.Range("B22").Resize(k, UBound(b, 2)).Value = b
    Application.ScreenUpdating = True
End Sub

 

[رضا على]

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