عمر طاهر قام بنشر يونيو 2, 2023 قام بنشر يونيو 2, 2023 (معدل) السلام عليكم ورحمة الله بمجهودكم أكاد انهي هذا الملف باقي ترحيل التاريخ والنوع والرقم مع الاصناف واصلاح صفحة التصفية في صفحة الشهر mywork.xlsm تم تعديل يونيو 2, 2023 بواسطه عمر طاهر تعديل الملف
أفضل إجابة محمد هشام. قام بنشر يونيو 3, 2023 أفضل إجابة قام بنشر يونيو 3, 2023 (معدل) تفضل اخي بالنسبة للترحيل اليك الكود التالي Sub Transfer() Dim K%, DL2%, S%, Rng As Range Dim WS_data As Worksheet: Set WS_data = ThisWorkbook.Sheets("تسجيل البيعة") Dim WS_dest As Worksheet: Set WS_dest = ThisWorkbook.Sheets("تسجيل المخزون") Application.ScreenUpdating = False K = WS_data.Range("C65500").End(xlUp).Row + 1 If WS_data.Range("C4") = Empty Then: MsgBox "ليس هناك بيانات", 64: Exit Sub If WS_data.Range("D2") = Empty Then: MsgBox "المرجوا ادخال التاريخ", 64: Exit Sub If WS_data.Range("H2") = Empty Then: MsgBox "المرجوا ادخال رقم الفاتورة", 64: Exit Sub With WS_dest DL2 = WS_dest.Range("C65500").End(xlUp).Row + 1 S = DL2 + K - 4 WS_dest.Range("F" & DL2 & ":F" & S) = WS_data.Range("c4:c" & K).Value WS_dest.Range("G" & DL2 & ":G" & S) = WS_data.Range("D4:D" & K).Value WS_dest.Range("H" & DL2 & ":H" & S) = WS_data.Range("E4:E" & K).Value WS_dest.Range("I" & DL2 & ":I" & S) = WS_data.Range("F4:F" & K).Value WS_dest.Range("C" & DL2 & ":C" & S) = WS_data.Range("D2") WS_dest.Range("D" & DL2 & ":D" & S) = WS_data.Range("H2") WS_dest.Range("E" & DL2 & ":E" & S) = WS_data.Range("J2") End With Set Rng = WS_data.Range("C4:I" & K).SpecialCells(xlCellTypeConstants) Rng.ClearContents Application.ScreenUpdating = True End Sub اما بالنسبة لتصفية البيانات يمكنك استخدام هدا الكود Sub BFVB() Dim lastRow As Long, lrow As Long, Article As Range Dim sh As Worksheet: Set sh = ThisWorkbook.Sheets("الشهر") lrow = sh.Range("A" & Rows.Count).End(xlUp).Row + 1 Set Rng = sh.Range("C2") Dim sh2 As Worksheet: Set sh2 = ThisWorkbook.Sheets("تسجيل المخزون") lastRow = sh2.Range("C" & Rows.Count).End(xlUp).Row If Rng.Value = Empty Then MsgBox "المرجو ادخال الصنف": Exit Sub On Error Resume Next Set Article = sh2.Range("G:G").Find(What:=Rng, LookIn:=xlValues, LookAt:=xlWhole) If Not Article Is Nothing Then Application.ScreenUpdating = False sh.Range("A4:G" & lrow).ClearContents sh2.Range("G1").AutoFilter Field:=5, Criteria1:="=" & Rng sh2.Range("C1").AutoFilter Field:=1, _ Criteria1:=">=" & sh.Range("E1").Value2, Operator:=xlAnd, _ Criteria2:="<=" & sh.Range("E2").Value2 With sh2 sh2.Range("C2:I" & lastRow).SpecialCells(xlCellTypeVisible).Copy sh.Range("A4").PasteSpecial xlPasteValues sh.Activate DL = sh.Range("A65500").End(xlUp).Row DC = sh.Cells(3, Columns.Count).End(xlToLeft).Column sh.Range("A3:G100").Borders.LineStyle = xlNone sh.Range(Cells(3, 1), Cells(DL, DC)).Borders.Weight = xlThin On Error GoTo 0 End With Else m = MsgBox("الصنف " & " " & Rng & " " & " " & "غير موجود", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "") End If On Error Resume Next sh2.ShowAllData Application.ScreenUpdating = True On Error GoTo 0 End Sub مع وضع هدا الكود في حدث شيت (الشهر) Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub If Target.Address(False, False) = "C2" And Target.Value <> "" Then Call BFVB End If End Sub mywork 6.xlsm تم تعديل يونيو 3, 2023 بواسطه Mohamed Hicham 1
عمر طاهر قام بنشر يونيو 3, 2023 الكاتب قام بنشر يونيو 3, 2023 منذ ساعه, Mohamed Hicham said: تفضل اخي بالنسبة للترحيل اليك الكود التالي Sub Transfer() Dim K%, DL2%, S%, Rng As Range Dim WS_data As Worksheet: Set WS_data = ThisWorkbook.Sheets("تسجيل البيعة") Dim WS_dest As Worksheet: Set WS_dest = ThisWorkbook.Sheets("تسجيل المخزون") Application.ScreenUpdating = False K = WS_data.Range("C65500").End(xlUp).Row + 1 If WS_data.Range("A4") = Empty Then: MsgBox "ليس هناك بيانات", 64: Exit Sub With WS_dest DL2 = WS_dest.Range("C65500").End(xlUp).Row + 1 S = DL2 + K - 4 WS_dest.Range("F" & DL2 & ":F" & S) = WS_data.Range("c4:c" & K).Value WS_dest.Range("G" & DL2 & ":G" & S) = WS_data.Range("D4:D" & K).Value WS_dest.Range("H" & DL2 & ":H" & S) = WS_data.Range("E4:E" & K).Value WS_dest.Range("I" & DL2 & ":I" & S) = WS_data.Range("F4:F" & K).Value WS_dest.Range("C" & DL2 & ":C" & S) = WS_data.Range("D2") WS_dest.Range("D" & DL2 & ":D" & S) = WS_data.Range("H2") WS_dest.Range("E" & DL2 & ":E" & S) = WS_data.Range("J2") End With Set Rng = WS_data.Range("C4:I" & K).SpecialCells(xlCellTypeConstants) Rng.ClearContents Application.ScreenUpdating = True End Sub اما بالنسبة لتصفية البيانات يمكنك استخدام هدا الكود Sub BFVB() Dim lastRow As Long, lrow As Long, Article As Range Dim sh As Worksheet: Set sh = ThisWorkbook.Sheets("الشهر") lrow = sh.Range("A" & Rows.Count).End(xlUp).Row + 1 Set Rng = sh.Range("C2") Dim sh2 As Worksheet: Set sh2 = ThisWorkbook.Sheets("تسجيل المخزون") lastRow = sh2.Range("C" & Rows.Count).End(xlUp).Row If Rng.Value = Empty Then MsgBox "المرجو ادخال الصنف": Exit Sub On Error Resume Next Set Article = sh2.Range("G:G").Find(What:=Rng, LookIn:=xlValues, LookAt:=xlWhole) If Not Article Is Nothing Then Application.ScreenUpdating = False sh.Range("A4:G" & lrow).ClearContents sh2.Range("G1").AutoFilter Field:=5, Criteria1:="=" & Rng sh2.Range("C1").AutoFilter Field:=1, _ Criteria1:=">=" & sh.Range("E1").Value2, Operator:=xlAnd, _ Criteria2:="<=" & sh.Range("E2").Value2 With sh2 sh2.Range("C2:I" & lastRow).SpecialCells(xlCellTypeVisible).Copy sh.Range("A4").PasteSpecial xlPasteValues sh.Activate DL = sh.Range("A65500").End(xlUp).Row DC = sh.Cells(3, Columns.Count).End(xlToLeft).Column sh.Range("A3:G100").Borders.LineStyle = xlNone sh.Range(Cells(3, 1), Cells(DL, DC)).Borders.Weight = xlThin On Error GoTo 0 End With Else m = MsgBox("الصنف " & " " & Rng & " " & " " & "غير موجود", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "") End If On Error Resume Next sh2.ShowAllData Application.ScreenUpdating = True On Error GoTo 0 End Sub مع وضع هدا الكود في حدث شيت (الشهر) Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub If Target.Address(False, False) = "C2" And Target.Value <> "" Then Call BFVB End If End Sub mywork 5.xlsm 972.1 kB · 0 downloads جزاك الله خيرا اخي لكن عند تعئة البيعة يعطي لا يوجد بيانات
محمد هشام. قام بنشر يونيو 3, 2023 قام بنشر يونيو 3, 2023 آسف أخي غير A4 الى C4 If WS_data.Range("A4") = Empty Then: MsgBox "ليس هناك بيانات", 64: Exit Sub With WS_dest
عمر طاهر قام بنشر يونيو 3, 2023 الكاتب قام بنشر يونيو 3, 2023 منذ ساعه, Mohamed Hicham said: آسف أخي غير A4 الى C4 If WS_data.Range("A4") = Empty Then: MsgBox "ليس هناك بيانات", 64: Exit Sub With WS_dest جزاك الله كل خير ممنون لطفك وتعاونك احترامي لك وللمنتدى شكا جزيلا لك 1
محمد هشام. قام بنشر يونيو 3, 2023 قام بنشر يونيو 3, 2023 العفو اخي قد تم تعديل الملف في المشاركة السابقة يمكنك تحميله من جديد 1
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.