اضافة اكواد لبرنامج

ابو .. عبدالرحمن · يوليو 30, 2023

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

اخواني الكرام

رفق لكم برنامج قمت بتصميمه على شكل صفحة رئيسية لإدخال البيانات وصفحة البيانات المدخلة

ولكن لم استطع الوصول الى اكواد اتمكن من اكمال هذا البرنامج

اتمنى من الخبراء اكمال الاكواد المطلوبة وهي : ( كود الترحيل (ادخال البيانات) ، كود التعديل ، كود البحث وقائمة البحث ، كود الطباعة لشيت البيانات ، كود الحذف )

بحيث يعمل البرنامج بالشكل الصحيح .... ولكم تحياتي وشكري

برنامج المعاملات المالية.xlsm

ابا اسماعيل · أغسطس 2, 2023

¨

جرب الكود التالي لعله المطلوب الخاص بي ترحيل

Private Sub CommandButton1_Click()
    ' ÊÍÏíÏ ÇáÕÝÍÉ ÇáÃÕáíÉ
    Dim wsSource As Worksheet
    Set wsSource = ThisWorkbook.Sheets("الرئسية")

    ' ÊÍÏíÏ ÇáÕÝÍÉ ÇáåÏÝ
    Dim wsTarget As Worksheet
    Set wsTarget = ThisWorkbook.Sheets("البيانات")

    ' ÊÑÍíá ÇáÈíÇäÇÊ
    Dim lastRow As Long
    lastRow = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row
    
    Dim searchRange As Range
    Set searchRange = wsTarget.Range("A2:A" & lastRow) ' äØÇÞ ÇáÈÍË Ýí ÇáÕÝÍÉ ÇáåÏÝ

    If Application.WorksheetFunction.CountIf(searchRange, wsSource.Range("C8").Value) = 0 Then
        ' äÓÎ ÑÞã ÇáãÚÇãáÉ ÅÐÇ áã íÊã ÇáÚËæÑ Úáíå Ýí ÇáÕÝÍÉ ÇáåÏÝ
        wsSource.Range("C8").Copy wsTarget.Cells(lastRow + 1, 1)
        wsSource.Range("C10").Copy wsTarget.Cells(lastRow + 1, 2)
        wsSource.Range("C12").Copy wsTarget.Cells(lastRow + 1, 3)
        wsSource.Range("C14").Copy wsTarget.Cells(lastRow + 1, 4)
        wsSource.Range("C16").Copy wsTarget.Cells(lastRow + 1, 5)
        wsSource.Range("C18").Copy wsTarget.Cells(lastRow + 1, 6)
          wsSource.Range("F8").Copy wsTarget.Cells(lastRow + 1, 7)
        wsSource.Range("F10").Copy wsTarget.Cells(lastRow + 1, 8)
        wsSource.Range("F12").Copy wsTarget.Cells(lastRow + 1, 9)
        wsSource.Range("F14").Copy wsTarget.Cells(lastRow + 1, 10)
        wsSource.Range("F16").Copy wsTarget.Cells(lastRow + 1, 11)
        wsSource.Range("F18").Copy wsTarget.Cells(lastRow + 1, 12)
        
          wsSource.Range("I8").Copy wsTarget.Cells(lastRow + 1, 7)
        wsSource.Range("I10").Copy wsTarget.Cells(lastRow + 1, 8)
        wsSource.Range("I12").Copy wsTarget.Cells(lastRow + 1, 9)
        wsSource.Range("I14").Copy wsTarget.Cells(lastRow + 1, 10)
        wsSource.Range("I16").Copy wsTarget.Cells(lastRow + 1, 11)
        wsSource.Range("I18").Copy wsTarget.Cells(lastRow + 1, 12)
        
        
    Else
        ' ÇÓÊÈÏÇá ÇáÈíÇäÇÊ ÅÐÇ Êã ÇáÚËæÑ Úáì ÑÞã ÇáãÚÇãáÉ ãæÌæÏðÇ ÈÇáÝÚá Ýí ÇáÕÝÍÉ ÇáåÏÝ
        Dim foundRow As Range
        Set foundRow = searchRange.Find(What:=wsSource.Range("C8").Value, LookIn:=xlValues, LookAt:=xlWhole)

        If Not foundRow Is Nothing Then
            wsTarget.Cells(foundRow.Row, 2).Value = wsSource.Range("C10").Value
            wsTarget.Cells(foundRow.Row, 3).Value = wsSource.Range("C12").Value
            wsTarget.Cells(foundRow.Row, 4).Value = wsSource.Range("C14").Value
            wsTarget.Cells(foundRow.Row, 5).Value = wsSource.Range("C16").Value
            wsTarget.Cells(foundRow.Row, 6).Value = wsSource.Range("C18").Value
             
             wsTarget.Cells(foundRow.Row, 7).Value = wsSource.Range("F10").Value
            wsTarget.Cells(foundRow.Row, 8).Value = wsSource.Range("F12").Value
            wsTarget.Cells(foundRow.Row, 9).Value = wsSource.Range("F14").Value
            wsTarget.Cells(foundRow.Row, 10).Value = wsSource.Range("F16").Value
            wsTarget.Cells(foundRow.Row, 11).Value = wsSource.Range("F18").Value
            
             wsTarget.Cells(foundRow.Row, 12).Value = wsSource.Range("I8").Value
             
            wsTarget.Cells(foundRow.Row, 13).Value = wsSource.Range("I10").Value
            wsTarget.Cells(foundRow.Row, 14).Value = wsSource.Range("I12").Value
            wsTarget.Cells(foundRow.Row, 15).Value = wsSource.Range("I14").Value
            wsTarget.Cells(foundRow.Row, 16).Value = wsSource.Range("I16").Value
            
        End If
    End If

End Sub

ابا اسماعيل · أغسطس 2, 2023

جرب الكود التالي

Private Sub CommandButton1_Click()
  
    Dim sourceValues() As Variant
    sourceValues = Array("C8", "C10", "C12", "C14", "C16", "C18", "F8", "F10", "F12", "F14", "F16", "F18", "I8", "I10", "I12", "I14", "I16", "I18 ")

    
    Dim wsSource As Worksheet
    Set wsSource = ThisWorkbook.Sheets("الرئيسية")

   
    Dim wsTarget As Worksheet
    Set wsTarget = ThisWorkbook.Sheets("البيانات")

    
    Dim lastRow As Long
    lastRow = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row

   
    Dim searchRange As Range
    Set searchRange = wsTarget.Range("A2:A" & lastRow)
    Dim foundRow As Range
    Set foundRow = searchRange.Find(What:=wsSource.Range("C8").Value, LookIn:=xlValues, LookAt:=xlWhole)

    If foundRow Is Nothing Then
      
        For i = 0 To UBound(sourceValues)
            wsSource.Range(sourceValues(i)).Copy wsTarget.Cells(lastRow + 1, i + 1)
        Next i
    Else
        
        For i = 0 To UBound(sourceValues)
            wsTarget.Cells(foundRow.Row, i + 1).Value = wsSource.Range(sourceValues(i)).Value
        Next i
    End If
End Sub

ابو .. عبدالرحمن · أغسطس 2, 2023

9 ساعات مضت, ابا اسماعيل said:

¨

جرب الكود التالي لعله المطلوب الخاص بي ترحيل

Private Sub CommandButton1_Click()
    ' ÊÍÏíÏ ÇáÕÝÍÉ ÇáÃÕáíÉ
    Dim wsSource As Worksheet
    Set wsSource = ThisWorkbook.Sheets("الرئسية")

    ' ÊÍÏíÏ ÇáÕÝÍÉ ÇáåÏÝ
    Dim wsTarget As Worksheet
    Set wsTarget = ThisWorkbook.Sheets("البيانات")

    ' ÊÑÍíá ÇáÈíÇäÇÊ
    Dim lastRow As Long
    lastRow = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row
    
    Dim searchRange As Range
    Set searchRange = wsTarget.Range("A2:A" & lastRow) ' äØÇÞ ÇáÈÍË Ýí ÇáÕÝÍÉ ÇáåÏÝ

    If Application.WorksheetFunction.CountIf(searchRange, wsSource.Range("C8").Value) = 0 Then
        ' äÓÎ ÑÞã ÇáãÚÇãáÉ ÅÐÇ áã íÊã ÇáÚËæÑ Úáíå Ýí ÇáÕÝÍÉ ÇáåÏÝ
        wsSource.Range("C8").Copy wsTarget.Cells(lastRow + 1, 1)
        wsSource.Range("C10").Copy wsTarget.Cells(lastRow + 1, 2)
        wsSource.Range("C12").Copy wsTarget.Cells(lastRow + 1, 3)
        wsSource.Range("C14").Copy wsTarget.Cells(lastRow + 1, 4)
        wsSource.Range("C16").Copy wsTarget.Cells(lastRow + 1, 5)
        wsSource.Range("C18").Copy wsTarget.Cells(lastRow + 1, 6)
          wsSource.Range("F8").Copy wsTarget.Cells(lastRow + 1, 7)
        wsSource.Range("F10").Copy wsTarget.Cells(lastRow + 1, 8)
        wsSource.Range("F12").Copy wsTarget.Cells(lastRow + 1, 9)
        wsSource.Range("F14").Copy wsTarget.Cells(lastRow + 1, 10)
        wsSource.Range("F16").Copy wsTarget.Cells(lastRow + 1, 11)
        wsSource.Range("F18").Copy wsTarget.Cells(lastRow + 1, 12)
        
          wsSource.Range("I8").Copy wsTarget.Cells(lastRow + 1, 7)
        wsSource.Range("I10").Copy wsTarget.Cells(lastRow + 1, 8)
        wsSource.Range("I12").Copy wsTarget.Cells(lastRow + 1, 9)
        wsSource.Range("I14").Copy wsTarget.Cells(lastRow + 1, 10)
        wsSource.Range("I16").Copy wsTarget.Cells(lastRow + 1, 11)
        wsSource.Range("I18").Copy wsTarget.Cells(lastRow + 1, 12)
        
        
    Else
        ' ÇÓÊÈÏÇá ÇáÈíÇäÇÊ ÅÐÇ Êã ÇáÚËæÑ Úáì ÑÞã ÇáãÚÇãáÉ ãæÌæÏðÇ ÈÇáÝÚá Ýí ÇáÕÝÍÉ ÇáåÏÝ
        Dim foundRow As Range
        Set foundRow = searchRange.Find(What:=wsSource.Range("C8").Value, LookIn:=xlValues, LookAt:=xlWhole)

        If Not foundRow Is Nothing Then
            wsTarget.Cells(foundRow.Row, 2).Value = wsSource.Range("C10").Value
            wsTarget.Cells(foundRow.Row, 3).Value = wsSource.Range("C12").Value
            wsTarget.Cells(foundRow.Row, 4).Value = wsSource.Range("C14").Value
            wsTarget.Cells(foundRow.Row, 5).Value = wsSource.Range("C16").Value
            wsTarget.Cells(foundRow.Row, 6).Value = wsSource.Range("C18").Value
             
             wsTarget.Cells(foundRow.Row, 7).Value = wsSource.Range("F10").Value
            wsTarget.Cells(foundRow.Row, 8).Value = wsSource.Range("F12").Value
            wsTarget.Cells(foundRow.Row, 9).Value = wsSource.Range("F14").Value
            wsTarget.Cells(foundRow.Row, 10).Value = wsSource.Range("F16").Value
            wsTarget.Cells(foundRow.Row, 11).Value = wsSource.Range("F18").Value
            
             wsTarget.Cells(foundRow.Row, 12).Value = wsSource.Range("I8").Value
             
            wsTarget.Cells(foundRow.Row, 13).Value = wsSource.Range("I10").Value
            wsTarget.Cells(foundRow.Row, 14).Value = wsSource.Range("I12").Value
            wsTarget.Cells(foundRow.Row, 15).Value = wsSource.Range("I14").Value
            wsTarget.Cells(foundRow.Row, 16).Value = wsSource.Range("I16").Value
            
        End If
    End If

End Sub

الله يعطيك العافية

حاولت اعدل فيه حاجات وارتبه من بعض الاعمدة الناقصة

حتى اصبح بهذا الشكل

Private Sub CommandButton1_Click()
' تحديد الصفحة الأصلية
Dim wsSource As Worksheet
Set wsSource = ThisWorkbook.Sheets("الرئيسية")
' تحديد الصفحة الهدف
Dim wsTarget As Worksheet
Set wsTarget = ThisWorkbook.Sheets("البيانات")
' ترحيل البيانات
Dim lastRow As Long
lastRow = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row
Dim searchRange As Range
Set searchRange = wsTarget.Range("A2:A" & lastRow) ' نطاق البحث في الصفحة الهدف
If Application.WorksheetFunction.CountIf(searchRange, wsSource.Range("C8").Value) = 0 Then
' نسخ رقم المعاملة إذا لم يتم العثور عليه في الصفحة الهدف
wsSource.Range("C8").Copy wsTarget.Cells(lastRow + 1, 1)
wsSource.Range("C10").Copy wsTarget.Cells(lastRow + 1, 2)
wsSource.Range("C12").Copy wsTarget.Cells(lastRow + 1, 3)
wsSource.Range("C14").Copy wsTarget.Cells(lastRow + 1, 4)
wsSource.Range("C16").Copy wsTarget.Cells(lastRow + 1, 5)
wsSource.Range("C18").Copy wsTarget.Cells(lastRow + 1, 6)
wsSource.Range("F8").Copy wsTarget.Cells(lastRow + 1, 7)
wsSource.Range("F10").Copy wsTarget.Cells(lastRow + 1, 8)
wsSource.Range("F12").Copy wsTarget.Cells(lastRow + 1, 9)
wsSource.Range("F14").Copy wsTarget.Cells(lastRow + 1, 10)
wsSource.Range("F16").Copy wsTarget.Cells(lastRow + 1, 11)
wsSource.Range("F18").Copy wsTarget.Cells(lastRow + 1, 12)
wsSource.Range("I8").Copy wsTarget.Cells(lastRow + 1, 13)
wsSource.Range("I10").Copy wsTarget.Cells(lastRow + 1, 14)
wsSource.Range("I12").Copy wsTarget.Cells(lastRow + 1, 15)
wsSource.Range("I14").Copy wsTarget.Cells(lastRow + 1, 16)
wsSource.Range("I16").Copy wsTarget.Cells(lastRow + 1, 17)
wsSource.Range("I18").Copy wsTarget.Cells(lastRow + 1, 18)

wsSource.Range("C8").Value = ""
wsSource.Range("C10").Value = ""
wsSource.Range("C12").Value = ""
wsSource.Range("C14").Value = ""
wsSource.Range("C16").Value = ""
wsSource.Range("C18").Value = ""
wsSource.Range("F8").Value = ""
wsSource.Range("F10").Value = ""
wsSource.Range("F12").Value = ""
wsSource.Range("F14").Value = ""
wsSource.Range("F16").Value = ""
wsSource.Range("F18").Value = ""
wsSource.Range("I8").Value = ""
wsSource.Range("I10").Value = ""
wsSource.Range("I12").Value = ""
wsSource.Range("I14").Value = ""
wsSource.Range("I16").Value = ""
wsSource.Range("I18").Value = ""
Else
' استبدال البيانات إذا تم العثور على رقم المعاملة موجودًا بالفعل في الصفحة الهدف
Dim foundRow As Range
Set foundRow = searchRange.Find(What:=wsSource.Range("C8").Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not foundRow Is Nothing Then
wsTarget.Cells(foundRow.Row, 1).Value = wsSource.Range("C8").Value
wsTarget.Cells(foundRow.Row, 2).Value = wsSource.Range("C10").Value
wsTarget.Cells(foundRow.Row, 3).Value = wsSource.Range("C12").Value
wsTarget.Cells(foundRow.Row, 4).Value = wsSource.Range("C14").Value
wsTarget.Cells(foundRow.Row, 5).Value = wsSource.Range("C16").Value
wsTarget.Cells(foundRow.Row, 6).Value = wsSource.Range("C18").Value
wsTarget.Cells(foundRow.Row, 7).Value = wsSource.Range("F8").Value
wsTarget.Cells(foundRow.Row, 8).Value = wsSource.Range("F10").Value
wsTarget.Cells(foundRow.Row, 9).Value = wsSource.Range("F12").Value
wsTarget.Cells(foundRow.Row, 10).Value = wsSource.Range("F14").Value
wsTarget.Cells(foundRow.Row, 11).Value = wsSource.Range("F16").Value
wsTarget.Cells(foundRow.Row, 12).Value = wsSource.Range("F18").Value
wsTarget.Cells(foundRow.Row, 13).Value = wsSource.Range("I8").Value
wsTarget.Cells(foundRow.Row, 14).Value = wsSource.Range("I10").Value
wsTarget.Cells(foundRow.Row, 15).Value = wsSource.Range("I12").Value
wsTarget.Cells(foundRow.Row, 16).Value = wsSource.Range("I14").Value
wsTarget.Cells(foundRow.Row, 17).Value = wsSource.Range("I16").Value
wsTarget.Cells(foundRow.Row, 18).Value = wsSource.Range("I18").Value  
        End If
    End If
End Sub

ولكن باقي البحث والتعديل والحذف

ملاحظة

بعد الترحيل ما يمسح رغم اني عملت له اومر لمسح الخلايا بعد الترحيل لكن مازال فيه اشكالية

اتمنى مواصلة العمل حتى يكتمل ولكم جزيل الشكر

**حسونة حسين** · أغسطس 3, 2023

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

اخى @ابو .. عبدالرحمن

لكل طلب موضوع منفصل

هذا طلبك الاول كود الترحيل (ادخال البيانات)

Option Explicit
Private arr As Variant, Temp As Variant, X
Private J As Long, P As Long

Private Sub Insert_Data_Click()
    If WSData.Range("C8") = "" Then MsgBox " لا بد من تسجيل رقم المعاملة ": Exit Sub
    kh_Application False
    ReDim Temp(1 To UBound(AR, 1) + 1)
    For J = 0 To UBound(AR)
        Temp(J + 1) = WSData.Range(AR(J))
    Next J
    WSResult.Range("A" & WSResult_LR).Resize(, UBound(Temp, 1)).Value = Temp
    MsgBox " تم ادخال البيانات بنجاح "
    Delete_Data_Click
    kh_Application True
End Sub

Private Sub Delete_Data_Click()
    kh_Application False
    For J = 0 To UBound(AR)
        WSData.Range(AR(J)) = ""
    Next J
    kh_Application True
    MsgBox " تم حذف البيانات بنجاح "
End Sub
Sub kh_Application(ibol As Boolean)
    With Application
        .ScreenUpdating = ibol
        .DisplayAlerts = ibol
        .EnableEvents = ibol
    End With
End Sub
Public Function WSData() As Worksheet
    Set WSData = ThisWorkbook.Worksheets("الرئيسية")
End Function
Public Function WSResult() As Worksheet
    Set WSResult = ThisWorkbook.Worksheets("البيانات")
End Function
Public Function AR() As Variant
    AR = Array("C8", "C10", "C12", "C14", "C16", "C18", "F8", "F10", "F12", "F14", "F16", "F18", "I8", "I10", "I12", "I14", "I16", "I18")
End Function
Public Function WSResult_LR() As Long
    WSResult_LR = Application.Max(1, WSResult.Cells(Rows.Count, 1).End(xlUp).Row) + 1
End Function

برنامج المعاملات المالية.xlsm

ابا اسماعيل · أغسطس 3, 2023

جرب كود البحث (ادخال رقم البحث في الخالية j5 لكن ما زال ينقصه بعد التعديلات ليقوم بعرض البيانات بالترتيب في القائمه لعلى احد من الاخوه ان يساعدك

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Address = "$J$5" Then
        
        If Not IsEmpty(Target.Value) Then
            
            Dim wsData As Worksheet
            Set wsData = ThisWorkbook.Sheets("البيانات")
            Dim searchRange As Range
            Dim foundCell As Range

            Set searchRange = wsData.Range("A:A")
            Set foundCell = searchRange.Find(What:=Target.Value, LookIn:=xlValues, LookAt:=xlWhole)


            If Not foundCell Is Nothing Then
                Dim rowNum As Long
                rowNum = foundCell.Row
                Dim dataRange As Range
                Set dataRange = wsData.Range("A" & rowNum & ":R" & rowNum)
                
 
                Dim wsSource As Worksheet
                Set wsSource = ThisWorkbook.Sheets("الرئيسية")
                
                Dim targetRange As Range
                Set targetRange = wsSource.Range("K7:K24")
                targetRange.Value = Application.Transpose(dataRange.Value)
            Else
               
                wsSource.Range("K7:K24").Value = ""
            End If
        Else
          
            wsSource.Range("K7:K24").Value = ""
        End If
    End If
End Sub

تم تعديل أغسطس 3, 2023 بواسطه ابا اسماعيل

ابو .. عبدالرحمن · أغسطس 4, 2023

مشكورين جميعاً على هذه الجهود المبذولة

واتمني ان يكتمل بقية الاوامر

بالنسبة للبحث حتى الان لم يضبط معي

**حسونة حسين** · أغسطس 5, 2023

اخى لكل موضوع طلب منفصل

مرفق بملف بعد ما تقوم بإدخال الاكواد التى انتهيت منها

موضحا ما تريد

تسجيل الدخول

اضافة اكواد لبرنامج

الردود الموصى بها

ابو .. عبدالرحمن

ابا اسماعيل

ابا اسماعيل

ابو .. عبدالرحمن

حسونة حسين

ابا اسماعيل

ابو .. عبدالرحمن

حسونة حسين

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information