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

نقل أعمدة محددة من ورقة الى أكثر من ورقة


أبو سجده
إذهب إلى أفضل إجابة Solved by عبدالله بشير عبدالله,

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

بسم الله الرحمن الرحيم

عليه نتوكل وبه نستعين نحمده سبحانه كما ينبغي أن يحمد

ونصلي ونسلم على رسوله محمد وعلى آله وصحبه والتابعين

السادة الأعزاء الكرام

السلام عليكم ورحمة الله وبركاته

أطمع وبحول الله تعالى وقوته فى ضرب ثلاثة عصافير بطلقة واحدة أى بكود واحد VBA

من شأنه القيام بنقل أعمدة محددة من ورقة المصدر " الرئيسية "

إلى ثلاثة أوراق عمل " الأولى / الثانية / الثالثه " على هذا النحو

الأعمدة أرقام  1 و 4 و 6 و 28 و 29 من الورقة الرئيسية إلى الورقة الأولى

الأعمدة أرقام من 1 إلى 6 والعمود رقم 46 من الورقة الرئيسية إلى الورقة الثانية

الأعمدة أرقام 1 و 4 و 6 و 17 و 18 والأعمدة من 28 إلى 45 من الورقة الرئيسية إلى الورقة الثالثه

مع مراعاة فضلا نقل هذة الأعمده بنفس تنسيقات ورقة المصدر " الرئيسية " كلصق قيم

نظرا لإحتواء الملف الأصلى على العديد من الصيغ ونظرا لأننى اتعامل مع كميات كبيرة من الصفوف

لذلك أتطلع الى طريقة مرنه وسريعة لتحقيق ذلك بفضل الله تعالى أولا ثم بفضلكم جميعا

والله ولى الصابرين ***** أخيكم / سعيد بيرم أبو سجدة

برجاء الإطلاع على المرفق وجزاكم الله خيرا

 

نقل أعمدة محددة من ورقة الى أكثر من ورقة.xlsm

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

اللهم صَلِّ وسلم على نبينا محمد وعلى آله وصحبه أجمعين

السلام عليكم ابو سجدة

 

جرب الكود التالى ومعك ان شاء الله حتى تحقق طلبك

الكود

Sub نقل_الأعمدة()
    Dim wsMain As Worksheet
    Dim wsFirst As Worksheet
    Dim wsSecond As Worksheet
    Dim wsThird As Worksheet
    Dim lastRow As Long
    Dim colArr As Variant

    Set wsMain = Sheets("الرئيسية")
    Set wsFirst = Sheets("الورقة الأولى")
    Set wsSecond = Sheets("الورقة الثانية")
    Set wsThird = Sheets("الورقة الثالثة")

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    colArr = Array(1, 4, 6, 28, 29)
    نقل_عمود_مع_التنسيقات wsMain, wsFirst, colArr

    colArr = Array(1, 2, 3, 4, 5, 6, 46)
    نقل_عمود_مع_التنسيقات wsMain, wsSecond, colArr

    colArr = Array(1, 4, 6, 17, 18, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45)
    نقل_عمود_مع_التنسيقات wsMain, wsThird, colArr
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Sub نقل_عمود_مع_التنسيقات(wsSource As Worksheet, wsTarget As Worksheet, cols As Variant)
    Dim lastRow As Long
    Dim i As Long
    Dim colNum As Integer

    lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row

    For i = LBound(cols) To UBound(cols)
        colNum = cols(i)
        wsTarget.Columns(colNum).ClearContents
    Next i

    For i = LBound(cols) To UBound(cols)
        colNum = cols(i)
        wsSource.Range(wsSource.Cells(1, colNum), wsSource.Cells(lastRow, colNum)).Copy
        wsTarget.Cells(1, colNum).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        wsTarget.Cells(1, colNum).PasteSpecial Paste:=xlPasteFormats
    Next i

    Application.CutCopyMode = False
End Sub

نقل أعمدة محددة من ورقة الى أكثر من ورقة.xlsm

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

  • أفضل إجابة
رابط هذا التعليق
شارك

وعليكم السلام ورحمه الله 

بعد اذن استاذنا @عبدالله بشير عبدالله يسعدني أن أشارك معكم هذه التجربة في محاولة مني للمساهمة والتفاعل الإيجابي والاستفاده من حضرتكم. 

Sub نقل_الأعمدة()
    Dim wsSource As Worksheet
    Dim wsFirst As Worksheet
    Dim wsSecond As Worksheet
    Dim wsThird As Worksheet
    Dim lastRow As Long

    ' تعيين ورقة المصدر
    Set wsSource = ThisWorkbook.Sheets("الرئيسية")
    
    ' تعيين أوراق العمل الأخرى
    Set wsFirst = ThisWorkbook.Sheets("الأولى")
    Set wsSecond = ThisWorkbook.Sheets("الثانية")
    Set wsThird = ThisWorkbook.Sheets("الثالثة")

    ' العثور على آخر صف في ورقة المصدر
    lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row

    ' نقل الأعمدة إلى الورقة الأولى
    wsSource.Range("A1:A" & lastRow).Copy
    wsFirst.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

    wsSource.Range("D1:D" & lastRow).Copy
    wsFirst.Range("B1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

    wsSource.Range("F1:F" & lastRow).Copy
    wsFirst.Range("C1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

    wsSource.Range("AB1:AB" & lastRow).Copy
    wsFirst.Range("D1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

    wsSource.Range("AC1:AC" & lastRow).Copy
    wsFirst.Range("E1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

    ' نقل الأعمدة إلى الورقة الثانية
    wsSource.Range("A1:F" & lastRow).Copy
    wsSecond.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

    wsSource.Range("AT1:AT" & lastRow).Copy
    wsSecond.Range("G1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

    ' نقل الأعمدة إلى الورقة الثالثة
    wsSource.Range("A1:A" & lastRow).Copy
    wsThird.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

    wsSource.Range("D1:D" & lastRow).Copy
    wsThird.Range("B1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

    wsSource.Range("F1:F" & lastRow).Copy
    wsThird.Range("C1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

    wsSource.Range("Q1:Q" & lastRow).Copy
    wsThird.Range("D1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

    wsSource.Range("R1:R" & lastRow).Copy
    wsThird.Range("E1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

    wsSource.Range("AB1:AR" & lastRow).Copy
    wsThird.Range("F1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

    ' تنظيف الحافظة
    Application.CutCopyMode = False

    MsgBox "تم نقل الأعمدة بنجاح!", vbInformation
End Sub

 

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

السلام عليكم جميعا ورحمة الله وبركاته

أخى عبدالله شكرا جزيلا لإهتمامكم فى ايجاد خل لهذا الموضوع فجزاكم الله تعالى خير الجزاء

بداية الكود الثانى هو بالفعل أسرع من الكود الأول لذا أرفقت هذا الملف مع الكود الثانى

أعلم جيدا أخى الفاضل أن الخلايا المدمجة قد تكون سبب فى بعض المعوقات فى تنفيذ الكود نظرا لتصميم الشيت 

ولكن اللى لربنا سبحانه وتعالى سيكون يسيرا بحوله وقوته

الكود يقوم بنقل الأعمدة المطلوبه ولكن بطريقة غير متجاورة للأعمدة ولرؤية ما أقصده برجاء الإطلاع على المرفق التالى 

والله المستعان وجزاكم الله خيرا

نقل أعمدة مع الكود الثانى - عبدالله بشير.xlsm

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

وعليكم السلام ورحمة الله وبركاتة 

الخلايا المدمجة لم اتعامل معها بالاكواد سابقا ولكن اضفت للكود قبل الترحبل الغاء الدمج  ثم اعدته بعد الترحيل 

ترحبل اعمدة معينة الى صفحات معينة.xlsm

 

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

حبيبى فى الله اخى وأستاذى / عبدالله

بداية جزاكم الله خيرا على صبركم وإهتمامكم بهذا الموضوع

نظرا لوجود خانتين للقرش والجنية فى ورقة المصدر  " الرئيسية " 

إضظررت وللأسف لعمل توسيط لرؤوس الأعمدة فى الصفين 6 و 7 

كما هو موضح فى المرفق الذى تم نشره فى المشاركة الأولى

لقد قمت بحذف الثلاثة أوراق المراد نقل الأعمدة إليهم **** ثم رجاءاً قم بتشغيل هذا الكود المرفق بهذا الملف لملاحظة ما أعنيه

Option Explicit

Sub test() ' *******************
    Dim wsMain As Worksheet
    Dim wsSheets As Variant
    Dim colArr As Variant
    Dim i As Long

    Set wsMain = Sheets("Source") ' **************
    wsSheets = Array("First", "Second", "Third") ' *******************

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim colsArr() As Variant
    colsArr = Array( _
        Array(1, 4, 6, 28, 29), _
        Array(1, 2, 3, 4, 5, 6, 46), _
        Array(1, 4, 6, 17, 18, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45) _
    )

    For i = LBound(wsSheets) To UBound(wsSheets)
        Abdullah_Basheer wsMain, Sheets(wsSheets(i)), colsArr(i) ' ************
    ' /////////////////////////////////////////////
    Next i

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Sub Abdullah_Basheer(wsSource As Worksheet, wsTarget As Worksheet, cols As Variant)
    
    ' ////////////////////////////////
    
    Dim lastRow As Long
    Dim i As Long
    Dim colNum As Integer

    lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row

    For i = LBound(cols) To UBound(cols)
        colNum = cols(i)
        wsTarget.Columns(colNum).ClearContents
    Next i

    For i = LBound(cols) To UBound(cols)
        colNum = cols(i)
        wsSource.Range(wsSource.Cells(1, colNum), wsSource.Cells(lastRow, colNum)).Copy
        wsTarget.Cells(1, colNum).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        wsTarget.Cells(1, colNum).PasteSpecial Paste:=xlPasteFormats
    Next i

    Application.CutCopyMode = False
End Sub

لأنه هو الأفضل من حيث السرعة ومن حيث نسخ التنسيقات بما فيهم نسخ رؤوس الأعمدة

بإستثناء الأعمدة الخاصة بخانتين القرش والجنيه فهل من سبيل لتعديل هذا الكود لعمل توسيط

لرؤوس الأعمدة الخاصة بخانتين القرش والجنية أما عن الأعمدة ذات القيم النصية فيمكن عمل Auto Fit لها كملائمة تلقائية

ضمن هذا الكود المتميز بحول الله تعالى ***** أعتذر للإطالة وجزاكم الله خيرا ****** والله المستعان

 

نقل أعمدة محددة من ورقة الى أكثر من ورقة+222222.xlsm

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

السلام عليكم ورحمة الله وبركانه

صبحكم الله بالخير

جرب الملف وان لم يكتمل حدد ما هو المطلوب

لك وافر التقدير والاحترام

نقل أعمدة محددة من ورقة الى أكثر من ورقة+222222.xlsm

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

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

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



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

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

Important Information