نجوم المشاركات

طريقة عمل نص تلقائي في word 2010 بسرعة وسهولة مرفوع على اليوتيوب

السلام عليكم جرب هذه Dim C As Integer Dim REC As Integer Dim EN Sub Dahmour() LR = Range("a" & Rows.Count).End(xlUp).Row EN = LR Range("a2:f" & LR).Sort key1:=Range("c2") LS = Sheets.Count For inx = 1 To WorksheetFunction.RoundUp((LR - 1) / (LS - 1), 0) If REC Mod 2 = 0 Or REC = 0 Then R Else RR End If Next Range("a2:f" & LR).Sort key1:=Range("a2") C = 0 REC = 0 EN = 0 End Sub Sub R() REC = REC + 1 LS = Sheets.Count For I = 2 To LS Sheets(I).Cells(Sheets(I).Cells(Rows.Count, 1).End(xlUp).Row + 1, 1) = Sheets(1).Cells(C + 2, 1) Sheets(I).Cells(Sheets(I).Cells(Rows.Count, 1).End(xlUp).Row, 2) = Sheets(1).Cells(C + 2, 2) Sheets(I).Cells(Sheets(I).Cells(Rows.Count, 1).End(xlUp).Row, 3) = Sheets(1).Cells(C + 2, 3) C = C + 1 If C + 1 = EN Then Exit For Next End Sub Sub RR() REC = REC + 1 LS = Sheets.Count For I = LS To 2 Step -1 Sheets(I).Cells(Sheets(I).Cells(Rows.Count, 1).End(xlUp).Row + 1, 1) = Sheets(1).Cells(C + 2, 1) Sheets(I).Cells(Sheets(I).Cells(Rows.Count, 1).End(xlUp).Row, 2) = Sheets(1).Cells(C + 2, 2) Sheets(I).Cells(Sheets(I).Cells(Rows.Count, 1).End(xlUp).Row, 3) = Sheets(1).Cells(C + 2, 3) C = C + 1 If C + 1 = EN Then Exit For Next End Sub تحياتي -++++توزيع الطلاب.rar

اخى الكريم هذا كود من المنتدى جربة ممكن يفيدك Book1.rar