aymanalsayed74 قام بنشر فبراير 1 مشاركة قام بنشر فبراير 1 رابط هذا التعليق شارك More sharing options...
محمد هشام. قام بنشر فبراير 1 مشاركة قام بنشر فبراير 1 (معدل) الكود الخاص بك بعد التعديل Sub tarheel() Application.ScreenUpdating = False Dim ws As Worksheet, xx As Integer, ir As Integer xx = Sheet1.Cells(32, 3).End(xlUp).Row For Each ws In ThisWorkbook.Worksheets If ws.Name <> Sheet1.Name Then For r = 8 To xx If Cells(r, 3).Value = ws.Name And Cells(r, 3).Value <> Empty Then Range(Cells(r, 3), Cells(r, 5)).Copy lr = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1 ws.Range("a" & lr).Value = Date ws.Range("b" & lr).PasteSpecial (xlPasteValues) End If Next End If Next Application.CutCopyMode = False Sheet1.Activate Sheet1.Range("b8:e21").ClearContents Application.ScreenUpdating = True End Sub بما انك تريد نسخ البيانات كقيم اليك حل اخر Sub test() Dim Sh As Worksheet Dim WS As Worksheet: Set WS = Worksheets("Sheet1") Dim iRow As Long, Rng As Range For Each Sh In ThisWorkbook.Worksheets If Sh.Name <> WS.Name Then Application.ScreenUpdating = False For iRow = 8 To 32 'WS.Range("C" & Rows.Count).End(xlUp).Row If WS.Cells(iRow, "C") Like Sh.CodeName Then Set Rng = WS.Range(WS.Cells(iRow, 3), WS.Cells(iRow, 5)) Sh.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = Date Sh.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).Resize(, 3).Value = Rng.Value 'WS.Range("B8:E21").ClearContents End If Next iRow End If Next Sh End Sub TEST SH.xlsm تم تعديل فبراير 1 بواسطه محمد هشام. اظافة حل اخر 1 رابط هذا التعليق شارك More sharing options...
aymanalsayed74 قام بنشر فبراير 3 الكاتب مشاركة قام بنشر فبراير 3 شكرا جزيلا اخي محمد هشام على ردك هذا وبارك الله في علمك بعد كتابة الكود بعد تعديله منكم ظهر هذا الخطأ ايضا نموذج جرد السيارات مع الطباعة - نسخة للتعديل.xlsm رابط هذا التعليق شارك More sharing options...
أفضل إجابة محمد هشام. قام بنشر فبراير 3 أفضل إجابة مشاركة قام بنشر فبراير 3 (معدل) Sub tarheel() Dim ws As Worksheet, xx As Integer, lr As Integer, r As Integer Dim sh As Worksheet: Set sh = Sheets(1) For Each ws In ThisWorkbook.Worksheets xx = sh.Cells(32, 3).End(xlUp).Row Application.ScreenUpdating = False For r = 8 To xx If sh.Cells(r, 3).Value = ws.Name And sh.Cells(r, 3).Value <> Empty Then sh.Range(Cells(r, 3), sh.Cells(r, 5)).Copy ws.Range("a" & Rows.Count).End(xlUp).Offset(1, 0).Value = Date ws.Range("b" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues End If Next Next Application.CutCopyMode = False sh.Range("b8:e21").ClearContents Application.ScreenUpdating = True End Sub 'OR**************************** Sub test() Dim Sh As Worksheet Dim WS As Worksheet: Set WS = Sheets(1) Dim iRow As Long, Rng As Range For Each Sh In ThisWorkbook.Worksheets If Sh.Name <> WS.Name Then Application.ScreenUpdating = False For iRow = 8 To 32 If WS.Cells(iRow, "C") Like Sh.Name Then Set Rng = WS.Range(WS.Cells(iRow, 3), WS.Cells(iRow, 5)) Sh.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = Date Sh.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).Resize(, 3).Value = Rng.Value WS.Range("B8:E21").ClearContents End If Next iRow End If Next Sh End Sub _نموذج جرد السيارات __مع الطباعة - نسخة للتعديل.xlsm تم تعديل فبراير 3 بواسطه محمد هشام. modifier code 1 رابط هذا التعليق شارك More sharing options...
aymanalsayed74 قام بنشر فبراير 3 الكاتب مشاركة قام بنشر فبراير 3 بوركتم يا اهل المغرب وجزاك الله خيرا رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان