اذهب الي المحتوي
أوفيسنا

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

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

بواسطه ابو .. عبدالرحمن
في منتدى الاكسيل Excel

 مشاركة

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

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

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

قام بنشر
قام بنشر

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

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

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

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

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

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

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

رابط هذا التعليق
شارك
ابا اسماعيل

ابا اسماعيل

قام بنشر
قام بنشر

¨

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

 

  

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 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

 

رابط هذا التعليق
شارك
ابو .. عبدالرحمن

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

قام بنشر
  • الكاتب
قام بنشر
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

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

ملاحظة

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

 

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

رابط هذا التعليق
شارك
حسونة حسين

حسونة حسين

قام بنشر
قام بنشر

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

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

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

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

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

رابط هذا التعليق
شارك
ابا اسماعيل

ابا اسماعيل

قام بنشر
قام بنشر (معدل)

جرب كود البحث (ادخال رقم  البحث في الخالية 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

 

تم تعديل بواسطه ابا اسماعيل
رابط هذا التعليق
شارك
زائر
هذا الموضوع مغلق.
 مشاركة
الذهاب الي قائمه المواضيع

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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept