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

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


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

السلام عليكم 

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

كشوفات 2021-2022.xlsx

تم تعديل بواسطه محمد عدنان
رابط هذا التعليق
شارك

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

 

تم تعديل بواسطه lionheart
  • Like 1
رابط هذا التعليق
شارك

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.

تم تعديل بواسطه lionheart
  • Like 1
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



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

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

Important Information