ترحيل عمود محدد

[محمد عدنان]

السلام عليكم 

ارجو المساعدة بماكرو  يقوم يترحيل اسماء الصف المختار من صفحة  الاسماء في الخلية G1  ثم يقوم بترحيل كامل الاسماء على صفحة كشف الاسماء مرتبة و شكرا لكم  الملف مرفق 

كشوفات 2021-2022.xlsx

تم تعديل نوفمبر 19, 2021 بواسطه محمد عدنان

[محمد عدنان]

ممكن المساعدة  و شكرا 

[lionheart]

Change the worksheets names according to your file

Sub Test()
    Const nRows As Long = 25
    Const sCells As String = "B5,D5,F5"
    Dim x, a, t, ws As Worksheet, sh As Worksheet, rng As Range, r As Range, lr As Long, n As Long, i As Long, m As Long, ii As Long
    Application.ScreenUpdating = False
        Set ws = ThisWorkbook.Worksheets("Names")
        Set sh = ThisWorkbook.Worksheets("Lists")
        sh.Range("B5:B29,D5:D29,F5:F25").ClearContents
        x = Application.Match(sh.Range("G1").Value, ws.Rows(1), 0)
        If Not IsError(x) Then
            lr = ws.Cells(Rows.Count, x).End(xlUp).Row
            If lr < 4 Then MsgBox "No Data", vbExclamation: Exit Sub
            Set rng = ws.Range(ws.Cells(4, x), ws.Cells(lr, x))
            If rng.Rows.Count > 75 Then MsgBox "No Place For All Data", vbExclamation: Exit Sub
            rng.Sort Key1:=ws.Cells(4, x), Order1:=xlAscending, Header:=xlNo
            a = rng.Value
            n = UBound(Split(sCells, ",")) + 1
            For i = 1 To n
                Set r = sh.Range(Split(sCells, ",")(i - 1))
                t = Slice(a, m, m + nRows - 1)
                m = m + nRows
                For ii = UBound(t) To LBound(t) Step -1
                    If IsError(t(ii)) Then t(ii) = Empty Else Exit For
                Next ii
                r.Resize(UBound(t)).Value = Application.Transpose(t)
                Set r = Nothing
            Next i
        End If
    Application.ScreenUpdating = True
End Sub

Function Slice(ByVal arr, ByVal f, ByVal t)
    Slice = Application.Index(arr, Evaluate("Transpose(Row(" & f + 1 & ":" & t + 1 & "))"))
End Function

 

تم تعديل نوفمبر 22, 2021 بواسطه lionheart

[محمد عدنان]

السلام عليم 

جزاك الله كل خير 

لكن عند ترحيل الاسماء فاذا كان العمود المرحل اقل من 50 يظهر الخطأ  #REF!

[lionheart]

Try comment out these two lines

If i = n Then

....

End If

 

[محمد عدنان]

السلام  عليكم 

مش فاهم شو اعمل 

[lionheart]

Delete the lines I referred to in the code

[محمد عدنان]

قمت بحذف ما اشرت اليه  قام باظهار الخطا لجميع الخلايا الفارغة 

[lionheart]

The code is working fine for me, please review the modified code in my main post

If there are more problems, please attach your file with real data.

[محمد عدنان]

السلام  عليكم 

الاوفيس المستخدم  2010

كشوفات الطلبة للعام 2021-2022 - Copy.xlsm

تم تعديل نوفمبر 22, 2021 بواسطه محمد عدنان

[lionheart]

Look my bro. You have wasted my time, I have told you that you have to comment out two specific lines and you didn't do that. Then I have modified the code for you and expected from you to copy the new code but it seems you didn't do that

Please back to the code and copy it again to your file and test the code for last time.

تم تعديل نوفمبر 22, 2021 بواسطه lionheart

[محمد عدنان]

thank you very mach

 

i am sorry because  i wasted your time 

 

thank you brother

[حسونة حسين]

تفضل اخى الكريم الملف بعد وضع الكود به

 

كشوفات الطلبة للعام 2021-2022.xlsm