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

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

عمر طاهر

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

 مشاركة
إذهب إلى أفضل إجابة Solved by محمد هشام.,

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

عمر طاهر

عمر طاهر

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

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

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

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

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

 

mywork.xlsm

تم تعديل بواسطه عمر طاهر
تعديل الملف
رابط هذا التعليق
شارك
  • أفضل إجابة
محمد هشام.

محمد هشام.

قام بنشر
  • أفضل إجابة
قام بنشر (معدل)

تفضل اخي بالنسبة للترحيل اليك الكود التالي  

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

تم تعديل بواسطه Mohamed Hicham
  • Like 1
رابط هذا التعليق
شارك
عمر طاهر

عمر طاهر

قام بنشر
  • الكاتب
قام بنشر
منذ ساعه, 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

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

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

asas.JPG

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

عمر طاهر

قام بنشر
  • الكاتب
قام بنشر
منذ ساعه, Mohamed Hicham said:

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

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

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

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

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

شكا جزيلا لك

  • Thanks 1
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

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

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

Important Information

  I accept