ترحيل المبيعات والمشتريات

**أيهاب ممدوح** · سبتمبر 9, 2024

السلام عليكم

ارجوا المساعده في الملف

المطلوب الاول هو عند تسجيل رقم الكود يستعدعي اسم الصنف وبعد تسجيل سعر البيع والملاحظات يتم الترحيل حسب الكود واسم الصفحه وبعدها يتم نقل نسخه من الصنف الي شيت المبيعات (بحيث يدرج في صفه المخزون كميه البيع وسعر البيع + ويرحل نسخه من الصنف بالكامل الي صفحه المبيعات

المطلوب الثاني هو عمليه الشراء عند تحديد اسم الصفحه يتم ترحيل البيات الي اخر صف بالصفحه وكذلك عمله نسخه بصفحه المشتريات

شكرا مقدما

مبيعات ومشتريات.xlsxFetching info...

**محمد هشام.** · سبتمبر 10, 2024

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

ربما أنت في حاجة لتوضيح طلبك أكثر أو إرفاق عينة للنتائج المتوقعة يدويا

**أيهاب ممدوح** · سبتمبر 10, 2024

مساء الخير

بخصوص الطلب الاول

المبيعات

بيحدث امرين الاول يتم تسجيل المبيعات في المخزون ( مقسم الي 3 صفحات لكل نوع صفحه ) لتقليل الكميه وفي نفس الشيت المخزن يتم تسجيل السعر البيع والملاحظات

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

المشتريات

يحدث امرين تسجيل الصنف في المخزون في اخر صف

الامر الثاني ترحيل الي صفحه المشتريات لعمل تقرير مشتريات بالبيانات المتاحه الكود و اسم الصنف والسعر الشراء والتاريخ

اتمني ان اكون وضحت

مبيعات ومشتريات.xlsxFetching info...

**محمد هشام.** · سبتمبر 13, 2024

الفكرة بالنسبة للمبيعات هي عند اختيار اسم صفحة المخزون من الخلية C3 سيتم انشاء قائمة منسدلة بأكواد الصنف المتوفرة في نفس الصفحة المختارة تلقائيا لتسهيل عملية البحث وعند اختيار كود الصنف يتم جلب اسم الصنف وبعد ادخال السعر والملاحظات والظغط على زر الترحيل يتم ترحيل بيانات التسجيل الى الصفحة المختارة مع ترحيل نفس البيانات الى ورقة المبيعات في الاعمدة المناسبة و اظافة تاريخ اليوم في العمود الاول من الجدول

المشتريات

بعد تحديد الصفحة الهدف من الخلية G3 واظافة بيانات التسجيل كود الصنف- اسم الصنف-السعر-الملاحظات يتم ترحيلها الى الصفحة المحددة مع نسخ نفس البيانات المتاحة لجدول المشتريات في الاعمدة المناسبة

ادا كانت قد فهمت طلبك بشكل صحيح فهدا سيوفي بالغرض

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

Sub CopyDatasale()
    Call ProcessTransfer("تسجيل", "المبيعات", Array(1, 2, 7, 8), Array(2, 3, 8, 9), True)
End Sub

Sub CopyDatabuy()
    Call ProcessTransfer("تسجيل", "المشتريات", Array(1, 2, 7, 8), Array(1, 2, 7, 8), False)
End Sub
'=======================================
Sub ProcessTransfer(registrationSheetName As String, destName As String, _
stockColumnsArr As Variant, salesColumnsArr As Variant, Cnt As Boolean)

    Dim WS As Worksheet, f As Worksheet, dest As Worksheet
    Dim arr As Variant, list As String, MSg As VbMsgBoxResult
    Dim i As Long

    Set WS = ThisWorkbook.Sheets(registrationSheetName)
    Set dest = ThisWorkbook.Sheets(destName)

    If destName = "المشتريات" Then
        arr = Array(WS.[G4], WS.[G5], WS.[G6], WS.[G7])
        list = WS.[G3].Value
    Else
        arr = Array(WS.[C4], WS.[C5], WS.[C6], WS.[C7])
        list = WS.[C3].Value
    End If

    For i = 0 To 3
        If arr(i) = "" Then
            MsgBox "يرجى إدخال: " & arr(i).Offset(0, -1), vbExclamation, "إنتباه"
            arr(i).Select
            Exit Sub
        End If
    Next

    On Error Resume Next
    Set f = ThisWorkbook.Sheets(list)
    On Error GoTo 0
    If f Is Nothing Then
        MsgBox "قائمة المخزون " & list & " غير موجودة", vbExclamation
        Exit Sub
    End If

    If MsgBox("ترحيل البيانات؟", vbYesNo + vbQuestion, "تأكــيد") = vbNo Then Exit Sub
    
    RegistrationData f, arr, stockColumnsArr
    RegistrationData dest, arr, salesColumnsArr, Cnt

    MsgBox list & ": تم ترحيل البيانات بنجاح إلى " & destName & " وقائمة المخزون", vbInformation

    MSg = MsgBox("هل ترغب في إفراغ بيانات التسجيل؟", vbYesNo + vbQuestion, "تفريغ الخلايا")
    If MSg = vbYes Then
        If destName = "المشتريات" Then
            WS.[G3:G7].ClearContents
        Else
            WS.[C3:C7].ClearContents
        End If
      End If
    
End Sub
'=======================================
Sub RegistrationData(sheet As Worksheet, arr As Variant, columnsArr As Variant, Optional Cnt As Boolean = False)
    Dim tbl As ListObject, lige As Range, TabBD As Range, i As Long
    
    Set tbl = sheet.ListObjects(1)
    Set lige = tbl.ListColumns(2).Range.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    Set TabBD = IIf(lige Is Nothing, tbl.ListRows(1).Range, lige.Offset(1))

    If Cnt Then
        TabBD.Cells(1, 1).Value = Format(Date, "dd/mmmm")
    End If
    For i = LBound(arr) To UBound(arr)
        TabBD.Cells(1, columnsArr(i)).Value = arr(i).Value
    Next i
End Sub

وفي حدث ورقة التسجيل ضع الكود التالي

Private Sub Worksheet_Change(ByVal Target As Range)
Dim dest As Worksheet, i As Long, lastRow As Long, TabBD As Boolean, Sh As String, itemCode As String, _
                           dict As Object, CRng As Range, a As Variant, tmp As Variant
    
Dim WS As Worksheet: Set WS = Sheets("تسجيل")

    On Error GoTo ErrorHandler
        Sh = Me.Range("C3").Value
        itemCode = Me.Range("C4").Value
        TabBD = False
        If Sh = "" Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    Select Case Target.Address
        Case Me.Range("C3").Address
            If Not Check(Sh, dest) Then
                TabBD = True
            Else
                lastRow = dest.Cells(dest.Rows.Count, "C").End(xlUp).Row
                Set CRng = dest.Range("C4:C" & lastRow)
                tmp = CRng.Value

                Set dict = CreateObject("Scripting.Dictionary")
                For i = 1 To UBound(tmp, 1)
                    If tmp(i, 1) <> "" And Not dict.Exists(tmp(i, 1)) Then
                        dict.Add tmp(i, 1), Nothing
                    End If
                Next i

                With WS.Range("L3:L" & WS.Cells(WS.Rows.Count, "L").End(xlUp).Row)
                    .ClearContents
                End With

                If dict.Count > 0 Then
                    With WS.Range("L3").Resize(dict.Count)
                        .Value = Application.Transpose(dict.Keys)
                    End With
                End If

                WS.Range("C4:C5").Value = ""
                Call Add_listeDéroulante
            End If

        Case Me.Range("C4").Address
            If Sh = "" Or itemCode = "" Then
                TabBD = True
            Else
                If Not Check(Sh, dest) Then
                    TabBD = True
                Else
                    lastRow = dest.Cells(dest.Rows.Count, "C").End(xlUp).Row
                    Set CRng = dest.Range("C4:C" & lastRow)
                    tmp = CRng.Value
                    
                    a = Application.Match(itemCode, Application.Index(tmp, 0, 1), 0)
                    If Not IsError(a) Then
                    WS.Range("C5").Value = dest.Cells(a + 3, "D").Value
                    Else
                             WS.Range("C5").Value = ""
                        TabBD = True
                    End If
                End If
            End If
 End Select
ExitHandler:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Exit Sub

ErrorHandler:
    MsgBox "Error : " & Err.Description, vbExclamation
    TabBD = True
    Resume ExitHandler
End Sub
Function Check(sheetName As String, ByRef dict As Worksheet) As Boolean
    On Error Resume Next
    Set dict = Sheets(sheetName)
    On Error GoTo 0
    If dict Is Nothing Then
        MsgBox "غير موجودة" & " " & sheetName & "  : " & "الصفحة", vbExclamation
        Check = False
    Else
        Check = True
    End If
End Function

مبيعات ومشتريات.xlsbFetching info...

تم تعديل سبتمبر 13, 2024 بواسطه محمد هشام.

**أيهاب ممدوح** · سبتمبر 14, 2024

اولا جزاك الله خير وشكرا جدا الحل ممتاز جدا

لو تكرمت بعض التعديلات البسيطه بخصوص المبيعات عند اختيار كود الصنف ( يرجي اظهار الوصف وليس اسم الصنف )

مع اضافه كميه المبيعات بقيمه 1 في ملف الصنف ( عامود المبيعات) بحيث يتم خصمه من المخزون وادخال تاريخ اليوم للعمليه في صفحه المخزون (عامود ترايخ البيع )

وعند الترحيل الي صفحه المبيعات يقوم بترحيل الصف من صفحه المخزون للمنتج بالكامل

الشراء

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

مع اضفاه الكميه ( الكميه ثابته دائمه 1) لجميع الاصناف

بخصوص السعر يذهب الي سعر الوحده وليس سعر البيع

شكرا جدا مقدما

مبيعات ومشتريات.xlsbFetching info...

بخصوص منع التكرار

بعد التجربه ظهر انه من الامكان تسجيل الكود مرتين بالتالي يحدث تضارب في المبيعات

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

**محمد هشام.** · سبتمبر 14, 2024

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

هناك بعض النقط يجب توضيحها

1) اضافه كميه المبيعات بقيمه 1 في ملف الصنف ( عامود المبيعات) بحيث يتم خصمه من المخزون ( مادا تقصد بالخصم واعتمادا على اي معيار )

2) منع تكرار الكود بحيث يختار اخر كود ولصنا له ويضيف الكود التالي له (هيتم جلب اخر كود من اين )

في 14‏/9‏/2024 at 14:03, محمد هشام. said:

مادا تقصد بالخصم واعتمادا على اي معيار

Expand

**أيهاب ممدوح** · سبتمبر 15, 2024

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

الفكرة المطلوبه ان بعد البيع تظهر انها تم بيعها ولا تظهر بالمخزون عند اضافه رقم واحد للقطعه المباعه في عمود كميه البيع سوف يتم تميزها انها غير موجودة

المعيار انها تم بيعها و بالتالي غير موجوده بالمخزون

**محمد هشام.** · سبتمبر 16, 2024

في 14‏/9‏/2024 at 14:34, أيهاب ممدوح said:

بخصوص منع التكرار

بعد التجربه ظهر انه من الامكان تسجيل الكود مرتين بالتالي يحدث تضارب في المبيعات

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

Expand

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

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

هناك احتمالية الاستغناء عن خلية ادخال الكود وتعويضها داخل الكود بانشاء تسلسل تلقائي للاكواد اي جلب اخر كود تم ترحيله مع اظافة +1

لهدا يصعب التعامل مع الملف في غياب معطيات كافية بالتفصيل

**أيهاب ممدوح** · سبتمبر 16, 2024

بالنسبه للشراء

فعلا المطلوب بخصوص كود المنتج ان يتم تلقائي مع اخر كود باضافه +1

بخصوص المبيعات لا يوجد تعديل سوي ادخال كميه 1 في كمه البيع بالمخزون وتاريخ اليوم فقط للعمليه

**محمد هشام.** · سبتمبر 16, 2024

يعني مسالة تكرار الكود واردة

**أيهاب ممدوح** · سبتمبر 16, 2024

لا غير وراد تكرار الكود للمنتج

**محمد هشام.** · سبتمبر 16, 2024

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

Sub CopyDatasale()
    Dim ws As Worksheet, f As Worksheet, dest As Worksheet
    Dim Sh As String, arr As Variant, rngToCopy As Range
    Dim tbl As ListObject, Tbl2 As ListObject, i&
    Dim OnRng As Range, Irow As Range, a As Range, n As Range

    Set ws = Sheets("تسجيل")
    Set dest = Sheets("المبيعات")
    Sh = ws.[C3].Value: Set f = ThisWorkbook.Sheets(Sh)
   
    arr = Array(ws.[C4], ws.[C5], ws.[C6], ws.[C7])
     For i = 0 To 3
     If arr(i) = "" Then MsgBox "يرجى إدخال: " & arr(i).Offset(0, -1), vbExclamation, "إنتباه": ws.Activate: arr(i).Select: Exit Sub
    Next
  On Error Resume Next
    Set f = ThisWorkbook.Sheets(Sh)
    On Error GoTo 0
    If f Is Nothing Then
        MsgBox "قائمة المخزون " & Sh & " غير موجودة", vbExclamation
        Exit Sub
    End If
    Dim MSg As VbMsgBoxResult
    MSg = MsgBox("هل ترغب في ترحيل بيانات التسجيل؟", vbYesNo + vbQuestion, "تأكيد الترحيل")
    If MSg = vbNo Then Exit Sub

    Set tbl = f.ListObjects(1)
    Set Tbl2 = dest.ListObjects(1)
    Set OnRng = tbl.ListColumns(2).Range.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    If Not OnRng Is Nothing Then
        Set a = OnRng.Offset(1)
    Else
        Set a = tbl.ListRows(1).Range
    End If

    '==== ترحيل البيانات إلى ورقة المخزون =====
    a.Cells(1, 1).Value = arr(0)  ' كود الصنف
    a.Cells(1, 3).Value = arr(1)  ' الاسم
    a.Cells(1, 6).Value = 1       ' الكمية
    a.Cells(1, 4).Value = arr(2)  ' الوصف
    a.Cells(1, 8).Value = arr(3)  ' الملاحظات
    a.Cells(1, 10).Value = Format(Date, "dd/mmmm")  ' التاريخ

    Set OnRng = tbl.ListColumns(2).Range.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    Set Irow = Tbl2.ListColumns(3).Range.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)

    If Not Irow Is Nothing Then
        Set n = Irow.Offset(1).Resize(1, 10)
    Else
        Set n = Tbl2.ListRows(1).Range.Resize(1, 10)
    End If
    '==== ترحيل البيانات إلى ورقة المبيعات =====

    Set rngToCopy = OnRng.Resize(1, 10)
    n.Value = rngToCopy.Value
    n.Cells(1, 1).Offset(0, -1).Value = Format(Date, "dd/mmmm")

End Sub

**أيهاب ممدوح** · سبتمبر 16, 2024

تم التجربه بخصوص الترحيل الي صفحه المبيعات ممتاز

بخصوص الترحيل الي صفحه المخزون قام بأضافه صف جديد بكود المنتج ولم يتعامل مع المنتج المسجل من قبل

مرسل ملف التجربه

مبيعات ومشتريات.xlsbFetching info...

**محمد هشام.** · سبتمبر 16, 2024

ادن ما نفهمه الان انك رغم ادخالك مثلا w3 يتم تجاهله واظافة كود جديد w4

**أيهاب ممدوح** · سبتمبر 16, 2024

هذا ما يحدث وهذا غير المطلوب

المطلوب هو الاضافه الي نفس المنتج اضافه باقي البيانات من كميه 1 وتاريخ البيع وسعر البيع والملاحظات

بخصوص السعر البيع يتم ترحيله الي سعر البيع وليس سعر الوحده

وعند استدعاء اصم الصنف يتم استعداء الوصف وليس الاسم

**محمد هشام.** · سبتمبر 16, 2024

في 16‏/9‏/2024 at 17:39, أيهاب ممدوح said:

بخصوص السعر البيع يتم ترحيله الي سعر البيع وليس سعر الوحده

وعند استدعاء اصم الصنف يتم استعداء الوصف وليس الاسم

Expand

تم تعديلها مع اظافة امكانية جلب اخر كود في الصفحة الهدف عند التغيير في الخلية G3

جرب هدا للمبيعات

Sub TransferData1()
    Dim ws As Worksheet, dest As Worksheet, sWS As Worksheet
    Dim arr As Variant, xdate As String
    Dim Clé As String, a As Range, n As Range
    Dim Sht As String, tbl2 As ListObject, Irow As Range

    xdate = Format(Date, "dd/mmmm")
    Set ws = Sheets("تسجيل")
    Sht = ws.Range("C3").Value

    On Error Resume Next
    Set dest = Sheets(Sht)
    On Error GoTo 0
    If dest Is Nothing Then
        MsgBox "صفحة المخازن" & Sht & " غير موجودة", vbExclamation
        Exit Sub
    End If
    Set sWS = Sheets("المبيعات")
    Clé = ws.Range("C4").Value
    arr = Array(ws.Range("C4").Value, ws.Range("C5").Value, ws.Range("C6").Value, ws.Range("C7").Value)
    
    For i = 0 To 3
        If arr(i) = "" Then
            MsgBox "يرجى إدخال: " & ws.Cells(4 + i, 2).Value, vbExclamation, "تنبيه"
            ws.Activate
            ws.Cells(4 + i, 3).Select
            Exit Sub
        End If
    Next i
    Set a = dest.Columns("C").Find(What:=Clé, After:=dest.Cells(4, 3), LookIn:=xlValues, LookAt:=xlWhole)
    If a Is Nothing Then
        MsgBox "لم يتم العثور على ُمعرّف المخزون " & Clé, vbExclamation
        Exit Sub
    End If
    a.Offset(0, 2).Value = arr(1)
    a.Offset(0, 6).Value = arr(2)
    a.Offset(0, 7).Value = arr(3)
    a.Offset(0, 5).Value = 1
    a.Offset(0, 9).Value = xdate
    Set tbl2 = sWS.ListObjects(1)
    Set Irow = tbl2.ListColumns(3).Range.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    If Not Irow Is Nothing Then
        Set n = Irow.Offset(1).Resize(1, tbl2.ListColumns.Count)
    Else
        Set n = tbl2.ListRows(1).Range.Resize(1, tbl2.ListColumns.Count)
    End If
    n.Cells(1, 1).Offset(0, -1).Value = xdate
    n.Cells(1, 1).Resize(1, 10).Value = a.Resize(1, 10).Value
    MsgBox "تم ترحيل البيانات بنجاح", vbInformation
End Sub

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

مبيعات ومشتريات V1.xlsbFetching info...

**أيهاب ممدوح** · سبتمبر 17, 2024

السلام عليكم

بخصوص المبيعات والمخزون بارك الله فيك ممتاز

المشتريات الكود لا يعمل

**محمد هشام.** · سبتمبر 17, 2024

في 17‏/9‏/2024 at 17:50, أيهاب ممدوح said:

المشتريات الكود لا يعمل

Expand

لم يتم اخي الفاضل اظافة الكود انا في انتظار الرد على سؤالي ما هي طريقة ترحيل المشتريات هل سيتم النسخ الى صفحات المخازن وورقة المشتريات دفعة واحدة مع تحديث الكود او مادا

على العموم على حسب ما فهمت الى غاية اللحظة ربما هدا ما تحاول فعله

Sub TransferData2()
    Dim i As Long, Cnt As Long
    Dim ws As Worksheet, f As Worksheet, sWS As Worksheet
    Dim Sh As String, arr As Variant
    Dim tbl As ListObject, a As Range, lige As Range
    Dim j As String, newCode As String, b As String

    Set ws = ThisWorkbook.Sheets("تسجيل")
    Sh = ws.[G3].Value
   
    arr = Array(ws.[G4], ws.[G5], ws.[G6], ws.[G7])
    For i = 0 To 3
        If arr(i) = "" Then
            MsgBox "يرجى إدخال: " & arr(i).Offset(0, -1), vbExclamation, "إنتباه"
            ws.Activate: arr(i).Select
            Exit Sub
        End If
    Next
    On Error Resume Next
    Set f = ThisWorkbook.Sheets(Sh)
    On Error GoTo 0
    If f Is Nothing Then
        MsgBox "قائمة المخزون " & Sh & " غير موجودة", vbExclamation
        Exit Sub
    End If

    If MsgBox("هل ترغب في ترحيل بيانات التسجيل؟", vbYesNo + vbQuestion, "تأكيد الترحيل") = vbNo Then Exit Sub
    Set tbl = f.ListObjects(1)
    On Error Resume Next
    Set lige = tbl.ListColumns(2).DataBodyRange.SpecialCells(xlCellTypeConstants).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    On Error GoTo 0

    '  الكود الجديد
    If Not lige Is Nothing Then
        j = lige.Value
        b = Left(j, Len(j) - Len(CStr(Val(j))))
        Cnt = Val(Right(j, Len(j) - Len(b)))
        newCode = b & Cnt + 1
    Else
        newCode = ws.[G4].Value
    End If
    If Not lige Is Nothing Then
        Set a = lige.Offset(1, 0)
    Else
        Set a = tbl.ListColumns(2).DataBodyRange.Cells(1, 1)
        If a.Value <> "" Then
            Set a = tbl.ListColumns(2).DataBodyRange.Cells(tbl.ListRows.Count + 1, 1)
        End If
    End If

    a.Value = newCode ' الكود
    a.Offset(0, 5).Value = 1 ' الكمية
    a.Offset(0, 2).Value = arr(1) ' الاسم
    a.Offset(0, 3).Value = arr(2) ' الوصف
    a.Offset(0, 7).Value = arr(3) ' الملاحظات
    a.Offset(0, 9).Value = Format(Date, "dd/mmmm") ' التاريخ

    Set sWS = Sheets("المشتريات")
    Set tbl = sWS.ListObjects(1)
   On Error Resume Next
    Set lige = tbl.ListColumns(3).Range.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    On Error GoTo 0

    If Not lige Is Nothing Then
        Set a = lige.Offset(1, 0)
    Else
        Set a = tbl.ListColumns(3).DataBodyRange.Cells(1, 1)
        If a.Value <> "" Then
            Set a = tbl.ListColumns(3).DataBodyRange.Cells(tbl.ListRows.Count + 1, 1)
        End If
    End If
    a.Cells(1, 1).Offset(0, -1).Value = Format(Date, "dd/mmmm") ' التاريخ
    a.Value = newCode ' الكود
    a.Offset(0, 5).Value = 1 ' الكمية
    a.Offset(0, 2).Value = arr(1) ' الاسم
    a.Offset(0, 3).Value = arr(2) ' الوصف
    a.Offset(0, 7).Value = arr(3) ' الملاحظات
    a.Offset(0, 9).Value = Format(Date, "dd/mmmm") ' التاريخ
End Sub

مبيعات ومشتريات V1.xlsbFetching info...

تم تعديل سبتمبر 18, 2024 بواسطه محمد هشام.

**أيهاب ممدوح** · سبتمبر 18, 2024

السلام عليكم

جزاك الله خير استاذ هشام

هو المطلوب ممتاز

لو أمكن كود تفريغ الخلايا بعد التسجيل شواء شراء او البيع في صفحه التسجيل

السلام عليكم

استاذ محمد هشام

بعد تجربه والوصول لمرحله متقدمه ظهر خطأ في الكود من بعد العدد 29 يقوم الكود بالعدد بشكل غريب حيث يتجاهل القيمه العشرية او المئات ويعامل مع الرقم الاحادي فقط ويبدا باعداد مختلفه غير متسلسل

مرفق الملف بعد التجربه بعد العدد 29

مبيعات ومشتريات V1.xlsbFetching info...

**محمد هشام.** · سبتمبر 18, 2024

في 18‏/9‏/2024 at 15:52, أيهاب ممدوح said:

و أمكن كود تفريغ الخلايا بعد التسجيل شواء شراء او البيع في صفحه التسجيل

Expand

يمكنك اظافة الكود التالي في اخر الكود مع تعديل عناوين الخلايا بما يناسبك

If MsgBox("تفريغ بيانات التسجيل ", vbYesNo + vbQuestion, "تأكيـــد") = vbYes Then
        ws.Range("G3:G7").ClearContents
    End If
    MsgBox "تم ترحيل البيانات بنجاح", vbInformatio

**محمد هشام.** · ديسمبر 24, 2024

Sub TransferData2()
    Dim i As Long, Cnt As Long
    Dim ws As Worksheet, f As Worksheet, sWS As Worksheet
    Dim Sh As String, arr As Variant
    Dim tbl As ListObject, a As Range, lige As Range
    Dim j As String, newCode As String, b As String

    Set ws = ThisWorkbook.Sheets("تسجيل")
    Sh = ws.[G3].Value
   
    arr = Array(ws.[G4], ws.[G5], ws.[G6], ws.[G7])
    For i = 0 To 3
        If arr(i) = "" Then
            MsgBox "يرجى إدخال: " & arr(i).Offset(0, -1), vbExclamation, "إنتباه"
            ws.Activate: arr(i).Select
            Exit Sub
        End If
    Next
    On Error Resume Next
    Set f = ThisWorkbook.Sheets(Sh)
    On Error GoTo 0
    If f Is Nothing Then
        MsgBox "قائمة المخزون " & Sh & " غير موجودة", vbExclamation
        Exit Sub
    End If

    If MsgBox("هل ترغب في ترحيل بيانات التسجيل؟", vbYesNo + vbQuestion, "تأكيد الترحيل") = vbNo Then Exit Sub
    Set tbl = f.ListObjects(1)
    On Error Resume Next
    Set lige = tbl.ListColumns(2).DataBodyRange.SpecialCells(xlCellTypeConstants).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    On Error GoTo 0

    '  الكود الجديد
    If Not lige Is Nothing Then
        j = lige.Value
        
'========= استبدل هدا '==============
'        b = Left(j, Len(j) - Len(CStr(Val(j))))
'        Cnt = Val(Right(j, Len(j) - Len(b)))
'        newCode = b & Cnt + 1
        
'======  بالكود التالي '==========
Dim tmp As String, textPart As String
For i = Len(j) To 1 Step -1
    If IsNumeric(Mid(j, i, 1)) Then
        tmp = Mid(j, i, 1) & tmp
    Else
        textPart = Left(j, i)
        Exit For
    End If
Next i

If tmp <> "" Then
    Cnt = CLng(tmp)
Else
    Cnt = 0
End If
newCode = textPart & (Cnt + 1)

    Else
        newCode = ws.[G4].Value
    End If
    If Not lige Is Nothing Then
        Set a = lige.Offset(1, 0)
    Else
        Set a = tbl.ListColumns(2).DataBodyRange.Cells(1, 1)
        If a.Value <> "" Then
            Set a = tbl.ListColumns(2).DataBodyRange.Cells(tbl.ListRows.Count + 1, 1)
        End If
    End If

    a.Value = newCode ' الكود
    a.Offset(0, 5).Value = 1 ' الكمية
    a.Offset(0, 2).Value = arr(1) ' الاسم
    a.Offset(0, 3).Value = arr(2) ' الوصف
    a.Offset(0, 7).Value = arr(3) ' الملاحظات
    a.Offset(0, 9).Value = Format(Date, "dd/mmmm") ' التاريخ

    Set sWS = Sheets("المشتريات")
    Set tbl = sWS.ListObjects(1)
    On Error Resume Next
    Set lige = tbl.ListColumns(3).Range.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    On Error GoTo 0

    If Not lige Is Nothing Then
        Set a = lige.Offset(1, 0)
    Else
        Set a = tbl.ListColumns(3).DataBodyRange.Cells(1, 1)
        If a.Value <> "" Then
            Set a = tbl.ListColumns(3).DataBodyRange.Cells(tbl.ListRows.Count + 1, 1)
        End If
    End If
    a.Cells(1, 1).Offset(0, -1).Value = Format(Date, "dd/mmmm") ' التاريخ
    a.Value = newCode ' الكود
    a.Offset(0, 5).Value = 1 ' الكمية
    a.Offset(0, 2).Value = arr(1) ' الاسم
    a.Offset(0, 3).Value = arr(2) ' الوصف
    a.Offset(0, 7).Value = arr(3) ' الملاحظات
    a.Offset(0, 9).Value = Format(Date, "dd/mmmm") ' التاريخ
End Sub

مبيعات ومشتريات V3.xlsbFetching info...

تم تعديل ديسمبر 25, 2024 بواسطه محمد هشام.

**أيهاب ممدوح** · ديسمبر 25, 2024

اخي الكريم

محمد هشام

تم التعديل بنجاح بخصوص العدد الجديد تم بشكل ممتاز

لكن اصبح مشكله بالترحيل حيث يقوم بالترحيل للصفحه الي عمود المبيعات والمفروض يتم الترحيل الي عمود المخزون بعدد 1

والترحيل لصفحه المشتريات لنفس الاعمده

مرفق الملف

مبيعات ومشتريات V2.xlsbFetching info...

تم تعديل ديسمبر 25, 2024 بواسطه أيهاب ممدوح

**محمد هشام.** · ديسمبر 25, 2024

ادن جرب الملف المرفق في المشاركة السابقة بعد التعديل

'========= استبدل هدا '==============
        b = Left(j, Len(j) - Len(CStr(Val(j))))
        Cnt = Val(Right(j, Len(j) - Len(b)))
        newCode = b & Cnt + 1
        
'======  بالكود التالي '==========
Dim tmp As String, textPart As String
For i = Len(j) To 1 Step -1
    If IsNumeric(Mid(j, i, 1)) Then
        tmp = Mid(j, i, 1) & tmp
    Else
        textPart = Left(j, i)
        Exit For
    End If
Next i

تم تعديل ديسمبر 25, 2024 بواسطه محمد هشام.

**أيهاب ممدوح** · ديسمبر 26, 2024

جزاك الله كل خير تم العمل بنجاح شكرا استاذ محمد

**أيهاب ممدوح** · ديسمبر 30, 2024

السلام عليكم

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

1-في حاله مكتوب اجل بالملاحظات يقوم بالترحيل الي حساب العميل

2-تاريخ العميله الي اخر صف موجود

3-الوصف من خليه (c10) الي الوصف بحساب العميل في اخر صف

4- سعر البيع الي عمود d باخر صف في صفحه العميل

5-المطلوب ترحيله التاريخ - (الوصف مع الكود= c10)- القيمه الي صفحه العميل

6-طبعا بفرض ان عدد العملاء كبير وليس 4 فقط

شكرا جزيلا

مبيعات ومشتريات V4.xlsbFetching info...

تم تعديل ديسمبر 30, 2024 بواسطه أيهاب ممدوح

تسجيل الدخول

ترحيل المبيعات والمشتريات

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

أيهاب ممدوح

محمد هشام.

أيهاب ممدوح

محمد هشام.

أيهاب ممدوح

محمد هشام.

أيهاب ممدوح

محمد هشام.

أيهاب ممدوح

محمد هشام.

أيهاب ممدوح

محمد هشام.

أيهاب ممدوح

محمد هشام.

أيهاب ممدوح

محمد هشام.

أيهاب ممدوح

محمد هشام.

أيهاب ممدوح

محمد هشام.

محمد هشام.

أيهاب ممدوح

محمد هشام.

أيهاب ممدوح

أيهاب ممدوح

Join the conversation

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

تصفح الموقع

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

Support

Important Information