السلام عليكم ورحمة الله تعالى وبراته 
أخي احمد لقد اتعبتك معي جربت ما قلت لي لكن المشكلة ما تزال موجودة 
على العموم ها هو الكود كما طلبت مني تعديله هل هو صحيح 
Sub husalah() 
Set FS = Sheets("الغيابات (2)") 
Set TS = Sheets("الحوصلة") 
ER = FS.UsedRange.Rows.Count 
EC = FS.UsedRange.Columns.Count 
TR = 5 
For FR = 6 To ER 
If FS.Cells(FR, 37) = False Then GoTo 3 
RN = "A" & FR & ":E" & FR 
FS.Range(RN).Copy 
TS.Cells(TR, 1).PasteSpecial Paste:=xlPasteValues 
TC = 7 
For FC = 6 To EC - 1 
Q1 = FS.Cells(FR, FC) 
If Q1 = 0 Or Q1 = "" Then GoTo 4 
TS.Cells(TR, TC) = Q1 
TC = TC + 1 
4 Next FC 
TR = TR + 1 
3 Next FR 
Application.CutCopyMode = False 
 
End Sub