تعديل علي كود استدعاء بيانات من شيت اليوميات

[Ahmed Saad 2017]

السلام عليكم ورحمة الله اعضاء الجروب

انا بعمل شيت مبيعات بيه فاتورة و يوميات مجمعه و ملصق ملخص بالفاتورة

وكنت عامل كود ترحيل بمساعدة من استاذ محمد هشام و تم ادراج كود استدعاء فواتير ولكن به بعض المشاكل في استدعاء البيانات في الاعمدة الصحيحه 

برجاء المساعدة في تعديل الكود 

وشكرا مقدما للجميع 

officena 1.xlsm

[محمد هشام.]

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

تفضل اخي ..اليك الكود التالي لاستدعاء  الفواتير بشرط رقم الفاتورة .مع اضافة  ظهور اشعار بوجودها  مسبقا في حالة كتابة رقمها في جدول الادخال كما جاء في طلبك . الكود لم ارفعه هنا قد تمت اضافته في حدث شيت ( مستند قيد)

وان شاء الله نكون انتهينا من الخطوة الثانية.

Sub Find_MH()                         
Set Sh1 = Worksheets("مستند قيد")
Set sh2 = Worksheets("اليومية العامه")
Dim lastrow As Long
Dim Mh As Long
Dim iCont As Integer
Dim r As Integer
Dim c As Integer
Dim MH2      As Worksheet
Dim MH3      As Worksheet
Dim Trouve As Range

Application.ScreenUpdating = False
If Len(Range("d5").Value) = 0 Then  ' '<--التحقق من وجود قيمة في خلية البحث 
  MsgBox "المرجوا ادخال رقم الفاتورة"
 Exit Sub
End If
With Sheets("اليومية العامه")  'في عمود (D) شيت الفواتير اليومية'<--- التحقق من وجود رقم الفاتورة
    Set Trouve = .Range("d:d").Find(what:=Sheet1.Range("d5"), LookIn:=xlValues, lookat:=xlWhole)
     If Trouve Is Nothing Then
       MsgBox (" !!!رقم الفاتورة غير مسجل مسبقا")
       Exit Sub
     Else
     End If
     End With
MH1 = Sh1.Range("D5").Value
                           ' '<--- في حالة تحقق الشرط
With sh2
    lastrow = .Cells(.Rows.Count, "b").End(xlUp).Row '+ 1
    Mh = WorksheetFunction.Match(MH1, .Range("D5:D" & lastrow), 0) + 4
    iCont = WorksheetFunction.CountIf(.Range("D5:D" & lastrow), MH1)
End With
X = 3
For c = 2 To 2
Sh1.Cells(X, 4) = sh2.Cells(Mh, c).Value   ' '<---عمود D  ( التاريخ - رقم الفاتورة _ الشركة_ '
Sh1.Cells(X + 1, 4) = sh2.Cells(Mh, c + 1).Value
'sh1.Cells(X + 3, 4) = sh2.Cells(Mh, c + 3).Value       ' '<--- تم تعويضها بمعادلة
'''=SI(D3="";"";CONCATENER(TEXTE($D$5;"0##########");" - ";$D$4;" - "&TEXTE('مستند قيد'!D3;"mm-yyyy")))

Sh1.Cells(X + 1, 6) = sh2.Cells(Mh, c + 15).Value  ' '<---عمود F
Sh1.Cells(X + 3, 6) = sh2.Cells(Mh, c + 17).Value
Sh1.Cells(X + 2, 6) = sh2.Cells(Mh, c + 16).Value
Sh1.Cells(3, 6) = sh2.Cells(Mh, c + 14).Value

Sh1.Cells(3, 2) = sh2.Cells(Mh, c + 10).Value  ' '<---عمود B
Sh1.Cells(4, 2) = sh2.Cells(Mh, c + 11).Value
Sh1.Cells(5, 2) = sh2.Cells(Mh, c + 12).Value
Sh1.Cells(6, 2) = sh2.Cells(Mh, c + 13).Value
X = X + 1

Set MH2 = Worksheets("اليومية العامه")
Set MH3 = Worksheets("مستند قيد")
lastrow = MH2.Cells(Rows.Count, "F").End(xlUp).Row
If MH2.FilterMode Then MH2.ShowAllData

Worksheets("مستند قيد").Range("b9:F51").ClearContents  ' '<---افراغ البيانات السابقة
With MH2.Rows(6) ' '<---  تحديد رقم صف رؤؤوس الاعمدة
            ' '<--- تحديد عمود وجودة القيمة المبحوث عنها Row4      ___________________________________' '<--تحديد خلية البحث
   .AutoFilter Field:=4, Criteria1:=Worksheets("مستند قيد").Range("D5").Value    ' ' <--- _____________________فلترة البيانات
    If MH2.Range("d6:d" & lastrow).SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
        MH2.Range("F7:J" & lastrow).SpecialCells(xlCellTypeVisible).Copy MH3.Range("b" & Rows.Count).End(3)(2) ' '<--- مكان اللصق
        MH3.Range("A9:G51").Borders.LineStyle = xlContinuous
                                                              ' '<---تسطير الجدول
    End If
    .Parent.AutoFilterMode = False  ' '<---الغاء الفلترة
End With

Next

Application.ScreenUpdating = True
End Sub

واليك اخي كود اضافي للترحيل  من شيت الفاتورة الى شيت الفواتير اليومية ربما تحتاجه يوما ما.

Sub TARHIL2()
  Dim LastRowF1 As Integer
  Dim NextRowF2 As Integer
  Dim RowCount As Integer
  Dim rngF1 As Range
  
  Dim Sh1 As Worksheet, Sh2 As Worksheet
  Set Sh1 = Worksheets("مستند قيد")
  Set Sh2 = Worksheets("اليومية العامه")
  Dim Arr As Variant

    
    Arr = Array([b3], [d3], [f3], [b4], [d4], [f4], [f5], [f6])
    For i = 0 To 7
        If Arr(i) = "" Then
            MsgBox "المرجوا ادخال البيانات"
            Arr(i).Select
            Exit Sub
        End If
 Next i
  With Sh1
    NextRowF2 = Sh2.Cells(Rows.Count, 6).End(xlUp).Row + 1
    If NextRowF2 < 9 Then NextRowF2 = 7
    
    LastRowF1 = .Cells(Rows.Count, 2).End(xlUp).Row - 1
    Set rngF1 = .Range(.Cells(9, "B"), .Cells(LastRowF1, "g"))
    RowCount = rngF1.Rows.Count
        
    Sh2.Cells(NextRowF2, "F").Resize(RowCount, rngF1.Columns.Count).Value = rngF1.Value
   
    Sh2.Cells(NextRowF2, "B").Resize(RowCount).Value = .Range("d3").Value
    Sh2.Cells(NextRowF2, "C").Resize(RowCount).Value = .Range("d4").Value
    Sh2.Cells(NextRowF2, "d").Resize(RowCount).Value = .Range("d5").Value
    Sh2.Cells(NextRowF2, "E").Resize(RowCount).Value = .Range("d6").Value
    Sh2.Cells(NextRowF2, "L").Resize(RowCount).Value = .Range("b3").Value
    Sh2.Cells(NextRowF2, "M").Resize(RowCount).Value = .Range("b4").Value
    Sh2.Cells(NextRowF2, "N").Resize(RowCount).Value = .Range("b5").Value
    Sh2.Cells(NextRowF2, "O").Resize(RowCount).Value = .Range("b6").Value
    Sh2.Cells(NextRowF2, "P").Resize(RowCount).Value = .Range("F3").Value
    Sh2.Cells(NextRowF2, "Q").Resize(RowCount).Value = .Range("F4").Value
    Sh2.Cells(NextRowF2, "R").Resize(RowCount).Value = .Range("F5").Value
    Sh2.Cells(NextRowF2, "S").Value = .Range("F6").Value
    Sh1.Range("b2").Value = Sh2.Range("d" & Rows.Count).End(xlUp).Value + 1
    
  End With
End Sub

بالتوفيق. في انتظار الرد بعد التجربة .

فاتورة_MH.xlsm

تم تعديل نوفمبر 25, 2022 بواسطه Mohamed Hicham

[Ahmed Saad 2017]

@Mohamed Hicham

اولا بشكرك جزيلا علي مجهودك وتعبك معايا 

ثانيا تم تجربة كود الاستدعاء يعمل بشكل رائع 

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

ثالثا تم اضافة شيت طباعة استيكر ملخص بي بيانات الشحنة و تم عمل شكل تجريبي بالمطلوب 

فاتورة_MH.xlsm

[محمد هشام.]

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

على العموم تمت اظافته الا زر الترحيل .

أما بالنسبة للطباعة ماهو المطلوب ؟

فاتورة_MH.xlsm

تم تعديل نوفمبر 27, 2022 بواسطه Mohamed Hicham

[Ahmed Saad 2017]

@Mohamed Hicham

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

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

وبشكرك مره أخري علي تعاونك و مجهودك بارك الله فيك أخي الكريم الغالي ❤️ 

 

[محمد هشام.]

جربت الملف الأخير؟ 

[Ahmed Saad 2017]

اقصد إن المشكلة ليست في الاستدعاء 

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

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

وبالفعل تم التجربة و التعديل و إضافة طلب الخطوة الثالثه 

 

15 ساعات مضت, Mohamed Hicham said:

جربت الملف الأخير؟ 

تم التجربة و بالفعل تم اضافة شرط الترحيل استاذ @Mohamed Hicham شكرا جزيلا لحضرتك 

كد بالفعل تم الانتهاء من المرحلة الثانية 

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