تعديل كود الترحيل

[مجاهد2013]

السلام عليكم

في الملف المرفق أريد ترحيل بيانات من data إلى data2 غيرت بعص الأعمدة في شيت داتا و غيرت كذلك في الكود( المنجز سابقا من طرف الأستاذ سليم حاصبيا) و لم أتحصل على النتيجة إذا كان ممكن أستاذ سليم أو غيره يصحح لي الخطأ.

Option Explicit
Sub give_data()
If ActiveSheet.Name <> "data" Then Exit Sub
Dim i%: i = 3
Dim Laste_Row%, k%, m%
Dim arr, arr_num()
Dim rg As Object
arr_num = Array(3, 53, 103, 153, 203, 253, 303, 353, 403, 453, 503, 553, 603, 653, 703, 753, 803, 853, 903, 953, 1003, 1053, 1103, 1153, 1203, 1253, 1303, 1353, 1403, 1453, 1503, 1553, 1603, 1653, 1703, 1753, 1803, 1853, 1903, 1953, 2003)
Laste_Row = Sheets("data").Cells(Rows.Count, 1).End(3).Row
Sheets("data2").Range("a3").Resize(3000, 3).ClearContents

Set rg = CreateObject("system.collections.arraylist")
With rg
 Do Until i > Laste_Row
  If Not .contains(UCase(Range("h" & i).Value)) Then .Add UCase(Range("h" & i).Value)
 i = i + 1
 Loop

  arr = .toarray
 End With
 For i = LBound(arr) To UBound(arr)
   m = arr_num(i)
    For k = 3 To Laste_Row%
      If Sheets("data").Cells(k, "H") = arr(i) Then
         With Sheets("data2").Cells(m, 1)
           .Value = Sheets("data").Cells(k, "A")
           .Offset(, 1) = Sheets("data").Cells(k, "Y")
           .Offset(, 2) = Sheets("data").Cells(k, "H")
            m = m + 1
         End With
       End If
     Next
  Next
  Set rg = Nothing: Erase arr_num: Erase arr
End Sub

عذرا ان لم تكن هذه هي الطريقة الصحيحة لعرض الموضوع

1411.xlsm

[سليم حاصبيا]

أولاً في هذه الحالة لست بحاحة الى  arr_num

ثانياً الكود الصحيح

Option Explicit
Sub give_data()
If ActiveSheet.Name <> "data" Then Exit Sub
  Dim Laste_Row%, k%, m%, i%
  Dim arr
  Dim rg As Object
Laste_Row = Sheets("data").Cells(Rows.Count, 1).End(3).Row
Sheets("data2").Range("A3").Resize(3000, 3).ClearContents
Set rg = CreateObject("system.collections.arraylist")
 
 i = 3
With rg
 Do Until i > Laste_Row
  If Not .Contains(UCase(Range("h" & i).Value)) Then .Add UCase(Range("h" & i).Value)
 i = i + 1
 Loop

  arr = .toarray
 End With
  m = 3
 For i = LBound(arr) To UBound(arr)
 
    For k = 3 To Laste_Row%
      If Sheets("data").Cells(k, "H") = arr(i) Then
         With Sheets("data2").Cells(m, 1)
           .Value = Sheets("data").Cells(k, "A")
           .Offset(, 1) = Sheets("data").Cells(k, "Y")
           .Offset(, 2) = Sheets("data").Cells(k, "H")
            m = m + 1
         End With
       End If
     Next
  Next
  Set rg = Nothing: Erase arr
End Sub

 

[مجاهد2013]

أولا الف شكر

ثانيا أستاذ سليم أنا أحتاج في الترحيل يكون لكل قسم 50صف القسم الثاني مثلا يبدأ من 51 و هكذا ..........لأن عند إضافة أي تلميذ من أي قسم عند الترحيل يترحل للقسم بتاعه لأني عندي في عمل ثاني أحتاج (selection) لكل قسم على حدى لعمل قائمة منسدلة  .

[سليم حاصبيا]

جرب هذا الكود

الكود فيما بعد نظراً لضعف النت

الملف مرفق

Salim_1411.xlsm

[مجاهد2013]

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

std_salim.xlsm

[سليم حاصبيا]

كان من المفروض رفع الملف مسبقاً دون تضييع وقت

الكود 

Option Explicit
Sub give_data_by_50()
If ActiveSheet.Name <> "data" Then Exit Sub
  Dim D As Worksheet, D2 As Worksheet
  Dim i%, x%, n%, Laste_Row%, Ro%, col%, m%, k%, last_col%
  Dim arr(), Tile()

Set D = Sheets("data"): Set D2 = Sheets("data2")
Laste_Row = D.Cells(Rows.Count, 1).End(3).Row
D2.Cells.Clear

x = (Laste_Row \ 50) + 1
k = 1
ReDim arr(1 To x)
  For m = 1 To x
  arr(m) = 50 * (k - 1) + 3
  k = k + 1
Next
Ro = 3: col = 1
 
 For k = 1 To UBound(arr)
    D2.Cells(Ro, col).Resize(50).Value = _
    D.Range("A" & arr(k)).Resize(50).Value
    
    D2.Cells(Ro, col + 1).Resize(50).Value = _
    D.Range("B" & arr(k)).Resize(50).Value
    
    D2.Cells(Ro, col + 2).Resize(50).Value = _
    D.Range("G" & arr(k)).Resize(, 50).Value
    D2.Cells(1, col + 3).ColumnWidth = 0.75
    D2.Cells(4, col + 3).Formula = "="""""
    col = col + 4
  Next
 last_col = D2.Cells(4, Columns.Count).End(1).Column
 Tile = Array("رقم ", "الاسم و اللقب ", "القسم")
 
 For m = 1 To last_col Step 4
    D2.Cells(2, m + 3).Resize(51). _
     Interior.ColorIndex = 40
    D2.Cells(2, m).Resize(, 3) = Tile
 Next
 
 With D2.Cells(2, 1).Resize(51, last_col - 1)
  .Borders.LineStyle = 1: .HorizontalAlignment = 1
  .VerticalAlignment = 2: .Font.Size = 14
  .Font.Bold = True: .InsertIndent 1
  .Columns.AutoFit
 End With

With D2.Cells(2, 1).Resize(, last_col - 1)
  .HorizontalAlignment = 3
  .Interior.ColorIndex = 6
End With
n = Application.CountA(D2.Cells(2, last_col - 2).Resize(50))
D2.Cells(n + 2, last_col - 3).Resize(50 - n + 1, 4).Clear
Set D = Nothing: Set D2 = Nothing
Erase arr: Erase Tile
End Sub

 

New_std_salim.xlsm

[مجاهد2013]

الف شكر أستاذ سليم مع تحياتي.🖕

[سليم حاصبيا]

وهذا الكود يقوم بنفس العمل لكن مع عدد متغير من الصفوف

يكفي ان تضع في الخلية I1 عدد الصفوف التي تريدا وتضغط على الزر Run

مع تحديد نطاق الطباعة حسب الداتا التي حصلنا عليها

Option Explicit
Sub give_data_by_Y()
If ActiveSheet.Name <> "data" Then Exit Sub
  Dim D As Worksheet, D2 As Worksheet
  Dim i%, x%, n%, Laste_Row%, Ro%, col%, m%, k%, last_col%
  Dim arr(), Tile()
  Dim y
Set D = Sheets("data"): Set D2 = Sheets("data2")
y = D.Range("i1")
Laste_Row = D.Cells(Rows.Count, 1).End(3).Row
D2.Cells.Clear

x = (Laste_Row \ y) + 1
k = 1
ReDim arr(1 To x)
  For m = 1 To x
  arr(m) = y * (k - 1) + 3
  k = k + 1
Next
Ro = 3: col = 1
  '++++++++++++++++++++++++++ Get The Result
 For k = 1 To UBound(arr)
    With D2.Cells(Ro, col).Resize(y)
    .Value = _
    D.Range("A" & arr(k)).Resize(y).Value
    
    .Offset(, 1).Value = _
    D.Range("B" & arr(k)).Resize(y).Value
    
    .Offset(, 2).Value = _
    D.Range("G" & arr(k)).Resize(, y).Value
    End With
    D2.Cells(1, col + 3).ColumnWidth = 0.75
    D2.Cells(4, col + 3).Formula = "="""""
    
    col = col + 4
  Next
 '++++++++++++++++++++++++++End Of The Result
 
 '__________________________Type The Titles
 last_col = D2.Cells(3, Columns.Count).End(1).Column
 Tile = Array("رقم ", "الاسم و اللقب ", "القسم")
 
 For m = 1 To last_col Step 4
    D2.Cells(2, m + 3).Resize(y + 1). _
     Interior.ColorIndex = 40
    D2.Cells(2, m).Resize(, 3) = Tile
 Next
 '__________________________ End Of Typing The Titles
 
 '++++++++++++++++++++++++++  Format The Result
 With D2.Cells(2, 1).Resize(y + 1, last_col)
  .Borders.LineStyle = 1: .HorizontalAlignment = 1
  .VerticalAlignment = 2: .Font.Size = 14
  .Font.Bold = True: .InsertIndent 1
  .Columns.AutoFit
 End With

With D2.Cells(2, 1).Resize(, last_col)
  .HorizontalAlignment = 3
  .Interior.ColorIndex = 6
End With

n = Application.CountA(D2.Cells(2, last_col - 2).Resize(y))
If n < y Then
D2.Cells(n + 2, last_col - 3).Resize(y - n + 1, 5).Clear
End If
'++++++++++++++++++++++++++ End Of The Format Of Result
D2.PageSetup.PrintArea = D2.Range("A2").Resize(y + 1, last_col).Address
Set D = Nothing: Set D2 = Nothing
Erase arr: Erase Tile
End Sub

File Included

 

New_std_salim_1.xlsm