اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


إذهب إلى أفضل إجابة Solved by سليم حاصبيا,

الردود الموصى بها

السلام عليكم

في الملف المرفق أريد ترحيل بيانات من 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

 

  • Like 3
رابط هذا التعليق
شارك

أولا الف شكر

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

رابط هذا التعليق
شارك

  • أفضل إجابة

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

الكود 

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

رابط هذا التعليق
شارك

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

يكفي ان تضع في الخلية 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

  • Like 2
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information