معرفة خطأ الكود

[aymanalsayed74]

[محمد هشام.]

 الكود الخاص بك بعد التعديل 

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, 2024 بواسطه محمد هشام.
اظافة حل اخر

[aymanalsayed74]

شكرا جزيلا اخي محمد هشام على ردك هذا وبارك الله في علمك

بعد كتابة الكود بعد تعديله منكم ظهر هذا الخطأ ايضا 

‫نموذج جرد السيارات ‫‬مع الطباعة - نسخة للتعديل.xlsm

[محمد هشام.]

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, 2024 بواسطه محمد هشام.
modifier code

[aymanalsayed74]

بوركتم يا اهل المغرب وجزاك الله خيرا