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

[عمر طاهر]

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

بمجهودكم أكاد انهي هذا الملف 

باقي ترحيل التاريخ والنوع والرقم مع الاصناف

واصلاح صفحة التصفية في صفحة الشهر

 

mywork.xlsm

تم تعديل يونيو 2, 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

[عمر طاهر]

منذ ساعه, 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

جزاك الله خيرا اخي

لكن عند تعئة البيعة يعطي لا يوجد بيانات

[محمد هشام.]

آسف أخي غير A4 الى C4

If WS_data.Range("A4") = Empty Then: MsgBox "ليس هناك بيانات", 64: Exit Sub
   With WS_dest

[عمر طاهر]

منذ ساعه, Mohamed Hicham said:

آسف أخي غير A4 الى C4

If WS_data.Range("A4") = Empty Then: MsgBox "ليس هناك بيانات", 64: Exit Sub
   With WS_dest

جزاك الله كل خير

ممنون لطفك وتعاونك

احترامي لك وللمنتدى

شكا جزيلا لك

[محمد هشام.]

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