التنقل بين السجلات برقم الفاتورة

[mahmoud nasr alhasany]

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

الرجاء مساعدتى فى هذا العمل

اريد التنقل بين السجلات برقم الفاتورة فقط دون غيرها من ارقام الفواتير الاخرى فى textbox8   

من خلال 

SpinButton2_SpinDown
SpinButton2_SpinUp

 

 

Private Sub TextBox8_Change()
    Dim ws As Worksheet
    Dim rng As Range
    Dim foundRows As New Collection
    Dim i As Long

    Set ws = ThisWorkbook.Sheets("تسجيل البيانات")
    Set rng = ws.Range("A2:L10000")

  '  foundRows.RemoveAll

    For Each cell In rng.Columns(1).Cells
        If cell.Value = TextBox8.Text Then
            foundRows.ADD cell.Row
        End If
    Next cell

    If foundRows.Count = 0 Then
        MsgBox "No matching records found."
        Exit Sub
    End If

    ' Display the first match
    i = 1
    DisplayRecord (foundRows(i))
End Sub
Private Sub SpinButton2_SpinDown()
    If i > 1 Then
        i = i - 1
        DisplayRecord (foundRows(i))
    End If
End Sub

Private Sub SpinButton2_SpinUp()
    If i < foundRows.Count Then
        i = i + 1
        DisplayRecord (foundRows(i))
    End If
End Sub


Private Sub DisplayRecord(rowNum As Long)
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("تسجيل البيانات")
    TextBox7.Text = ws.Cells(rowNum, 2).Value
    ComboBox1.Text = ws.Cells(rowNum, 4).Value
    ComboBox2.Value = ws.Cells(rowNum, 5).Value
    ComboBox3.Value = ws.Cells(rowNum, 6).Value
    ComboBox4.Value = ws.Cells(rowNum, 7).Value
    TextBox3.Text = ws.Cells(rowNum, 8).Value
    TextBox4.Text = ws.Cells(rowNum, 9).Value
    TextBox5.Text = ws.Cells(rowNum, 10).Value
    TextBox6.Text = ws.Cells(rowNum, 11).Value
    ComboBox5.Value = ws.Cells(rowNum, 12).Value
End Sub

textbox8

بحث والتنقل بين السجلات برقم الفاتورة.xlsm

تم تعديل ديسمبر 14 بواسطه mahmoud nasr alhasany

[محمد هشام.]

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

 ربما هدا ما تقصده

ادا كنت قد فهمت طلبك بشكل صحيح يمكنك حدف جميع الأكواد السابقة  فهدا سيوفي بالغرض  بعد إظافة عنصر Label جديد بإسم  Label15  لإظهار عدد السجلات كما في الصورة المرفقة 

Public WS As Worksheet

Private Sub UserForm_Initialize()
    Set WS = Sheets("تسجيل البيانات")
End Sub

Private Sub Navigation(r As Integer)
    Dim NInvoice As String, tmp As Long, Col As Long
    NInvoice = Trim(TextBox8.Text)
    
    If NInvoice = "" Then
        MsgBox "يرجى إدخال رقم الفاتورة", vbExclamation
        Exit Sub
    End If
    
    tmp = TextBox8.Tag
    Col = FndRow(NInvoice, tmp, r)
    
    If Col = 0 Then
        MsgBox TextBox8.Value & " : " & "لا يوجد سجلات " & IIf(r = 1, "لاحقة", "سابقة") & _
        " بنفس رقم الفاتورة", vbExclamation
    Else
        ContrArr Col
    End If
End Sub

Private Function FndRow(facture As String, c As Long, r As Integer) As Long
    Dim tmp As Long, lastRow As Long
    lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row
    
    If r = 1 Then
        For tmp = c + 1 To lastRow
            If WS.Cells(tmp, 1).Value = facture Then
                FndRow = tmp
                Exit Function
            End If
        Next tmp
    Else
        For tmp = c - 1 To 2 Step -1
            If WS.Cells(tmp, 1).Value = facture Then
                FndRow = tmp
                Exit Function
            End If
        Next tmp
    End If
    FndRow = 0
End Function

Private Sub ContrArr(tmp As Long)
    Dim n As Variant
    n = Array("TextBox7", "ComboBox1", "ComboBox2", "ComboBox3", "ComboBox4", _
              "TextBox3", "TextBox4", "TextBox5", "TextBox6", "ComboBox5")
    
    If Me.TextBox8.Text = "" Then
        ClearControls
    Else
        Me.TextBox8.Tag = tmp
        For i = LBound(n) To UBound(n)
            Me.Controls(n(i)).Text = WS.Cells(tmp, i + 2).Value
        Next i
        
        tblUpdate tmp
    End If
End Sub

Private Sub SpinButton2_SpinDown()
    Navigation 1
End Sub

Private Sub SpinButton2_SpinUp()
    Navigation -1
End Sub

Private Sub résultats(facture As String)
    Dim Irow As Long
    Irow = ColRecherche(facture)
    If Irow = 0 Then
        MsgBox TextBox8.Value & " : " & "لا يوجد بيانات مطابقة لرقم الفاتورة", vbExclamation, "إنتـــباه"
        Me.TextBox8.Text = ""
        Label15.Caption = "السجل 1 من 1"
        Label15.Visible = False
    Else
        ContrArr Irow
    End If
End Sub

Private Function ColRecherche(facture As String) As Long
    Dim ColA As Range, cell As Range
    Set ColA = WS.Range("A2:A" & WS.Cells(WS.Rows.Count, 1).End(xlUp).Row)
    For Each cell In ColA
        If cell.Value = facture Then
            ColRecherche = cell.Row
            Exit Function
        End If
    Next cell
    
    ColRecherche = 0
End Function

Private Sub ClearControls()
    Dim n As Variant
    n = Array("TextBox7", "ComboBox1", "ComboBox2", "ComboBox3", _
    "ComboBox4", "TextBox3", "TextBox4", "TextBox5", "TextBox6", "ComboBox5")
    For i = LBound(n) To UBound(n)
        Me.Controls(n(i)).Text = ""
    Next i
    
    Me.TextBox8.Tag = ""
    Label15.Caption = "السجل 1 من 1"
    Label15.Visible = False
End Sub

Private Sub TextBox8_Change()
    If Me.TextBox8.Text = "" Then
        ClearControls
        Label15.Visible = False
        Exit Sub
    End If
    If Not IsNumeric(Me.TextBox8.Text) Then
        MsgBox "الرجاء إدخال قيمة رقمية فقط", vbExclamation
        Me.TextBox8.Text = ""
        ClearControls
        Exit Sub
    End If
    résultats Trim(TextBox8.Text)
End Sub

Private Sub tblUpdate(tblRow As Long)
  Dim facture As String, tblCount As Long, tmp As Long, lastRow As Long, tblMatch As Long
    
    facture = Trim(TextBox8.Text)
    lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row
    tblMatch = 0: tblCount = 0
    For tmp = 2 To lastRow
        If WS.Cells(tmp, 1).Value = facture Then
            tblCount = tblCount + 1
            If tmp = tblRow Then
                tblMatch = tblCount
            End If
        End If
    Next tmp
    
    Label15.Caption = "السجل " & tblMatch & " من " & tblCount
    Label15.Visible = True
End Sub

لقد قمت برفع ملفين: الأول بدون إظهار عدد السجلات  والثاني يقوم بإظهارها يمكنك اختيار ما يناسبك

بالتوفيق...........

البحث والتنقل.rar

تم تعديل الأحد at 18:52 بواسطه محمد هشام.

[mahmoud nasr alhasany]

احسنت 1 / محمد هشام.

الف شكر لك

[mahmoud nasr alhasany]

للاسف لقد لاحظت يوجد خطاء فى التنقل بين البيانات فى الفورم  اريد تنقل البيانات مثل ترتيب  هذا الاعمدة

Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("تسجيل البيانات")
    TextBox7.Text = ws.Cells(rowNum, 2).Value
    ComboBox1.Text = ws.Cells(rowNum, 4).Value
    ComboBox2.Value = ws.Cells(rowNum, 5).Value
    ComboBox3.Value = ws.Cells(rowNum, 6).Value
    ComboBox4.Value = ws.Cells(rowNum, 7).Value
    TextBox3.Text = ws.Cells(rowNum, 8).Value
    TextBox4.Text = ws.Cells(rowNum, 9).Value
    TextBox5.Text = ws.Cells(rowNum, 10).Value
    TextBox6.Text = ws.Cells(rowNum, 11).Value
    ComboBox5.Value = ws.Cells(rowNum, 12).Value

 

تم تعديل ديسمبر 15 بواسطه mahmoud nasr alhasany

[محمد هشام.]

يمكنك  تعديل كود عرض الأعمدة بترتيب العناصر على الشكل التالي 

Private Sub ContrArr(tmp As Long)
    Dim controls As Variant, columns As Variant, i As Integer
    controls = Array("TextBox7", "ComboBox1", "ComboBox2", "ComboBox3", "ComboBox4", _
                     "TextBox3", "TextBox4", "TextBox5", "TextBox6", "ComboBox5")
    columns = Array(2, 4, 5, 6, 7, 8, 9, 10, 11, 12)

    If Me.TextBox8.Text = "" Then
        ClearControls
    Else
        Me.TextBox8.Tag = tmp

        For i = LBound(controls) To UBound(controls)
            Me.controls(controls(i)).Text = WS.Cells(tmp, columns(i)).Value
        Next i

        tblUpdate tmp
    End If
End Sub

 

البحث والتنقل.rar

[mahmoud nasr alhasany]

الف شكر 1 / محمد هشام.

احسنت والله