ترحيل البيانات من ورقة إلى أخرى

[ناصرالمصرى]

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

بوركتم جميعا وطابت أوقاتكم بكل خير

فى هذا الملف ورقتان الأولى تسمى DATA  والثانية تسمى Summary

تحتوى الورقة DATA  على مابقرب من 50 عمود ما أريد القيام به هو ترحيل الأعمدة التسعة الأولى من الورقة DATA إلى الورقةSummary  

كلصق قيم هذة واحدة أما النقطة الأخرى والأخيرة هى تخصيص تنسيق معين لكل عمود من الأعمدة التسعة التى سيتم ترحليها

من الورقة  DATA الى الورقة Summary  كنوع  وحجم الخط وتنسيق الأرقام وعرض العمود الى أخره من التنسيقات

فهل يمكن تحقيق ذلك بطريقة سهلة وسريعة بإستخدام المصفوفات إن جاز التعبير نظرا للكم الهائل لعدد الصفوف

شاكر فضل حضراتكم لطيب المشاركة وجزاكم الله خيرا

 

Book1.xlsm

تم تعديل نوفمبر 8 بواسطه ناصرالمصرى

[محمد هشام.]

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

يمكنك استخدام الكود التالي مع تعديل التنسيقات بما يناسبك 

Sub TransferDataAndFormat()
    Dim WS As Worksheet, dest As Worksheet, ColArr As Variant
    Dim OnRng As Variant, lastRow As Long, n As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Set WS = Sheets("DATA")
    Set dest = Sheets("Summary")
    
    lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row
    If lastRow < 8 Then Exit Sub
    OnRng = WS.Range("A8:I" & lastRow).Value
    dest.Range("A8").Resize(lastRow - 7, 9).Value = OnRng
    
    ColArr = Array(25, 23, 22, 13, 18, 16, 25, 30, 20)

    With dest
        .Columns.Font.Name = "Arial"
        .Columns.Font.Size = 14
        
        For n = 1 To 9
            Select Case n
                Case 1
                    .Columns(n).NumberFormat = "###0"
                Case 2
                    .Columns(n).NumberFormat = "#,##0"
                Case 3
                    .Columns(n).NumberFormat = "#,##0.00"
                Case 4
                    .Columns(n).NumberFormat = "0.00%"
                Case 5
                    .Columns(n).NumberFormat = "@"
                Case 6
                    .Columns(n).NumberFormat = "dd/mm/yyyy"
                Case 7
                    .Columns(n).NumberFormat = "$#,##0.00"
                Case 8
                    .Columns(n).NumberFormat = "0.00%"
                Case 9
                    .Columns(n).NumberFormat = "General"
            End Select
            
            .Columns(n).ColumnWidth = ColArr(n - 1)
        Next n
    End With

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

 

Book1.xlsm

تم تعديل نوفمبر 9 بواسطه محمد هشام.

[ناصرالمصرى]

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

أولا ماذا عن رؤوس الأعمدة **** مع حذف الورقة Summary ثم تشغيل الكود الخاص بك لايتم نسخ رؤوس الأعمدة

ثانيا وانا أعتذر عن ذلك لعدم التوضيح أريد ان يبدأ الترحيل فى الورقة Summary بداية من الصف الثانى

فهل من ذلك سبيل مرة أخرى شاكر فضل حضرتك وجزاكم الله خيرا

[محمد هشام.]

يمكنك فقط تعديل السطور التالية 

11 ساعات مضت, ناصرالمصرى said:

ماذا عن رؤوس الأعمدة

  OnRng = WS.Range("A7:I" & lastRow).Value

11 ساعات مضت, ناصرالمصرى said:

أريد ان يبدأ الترحيل فى الورقة Summary بداية من الصف الثانى

 dest.Range("A2").Resize(lastRow - 6, 9).Value = OnRng

اليك مثال لتنفيد طلبك 

 Set WS = Sheets("DATA"): Set dest = Sheets("Summary")
    lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row
    If lastRow < 8 Then Exit Sub
    
    'افراغ البيانات السابقة
    dest.Range("A2:I" & dest.Cells(dest.Rows.Count, 1).End(xlUp).Row).Clear
    
    ' نطاق البيانات المرغوب نسخها
    OnRng = WS.Range("A7:I" & lastRow).Value
    
    ' تحديد مكان اللصق
    dest.Range("A2").Resize(lastRow - 6, 9).Value = OnRng
    
    'عرض الاعمدة
    ColArr = Array(30, 23, 22, 13, 18, 16, 25, 30, 20)
    
    '  حجم ونوع الخط
    With dest
        .Columns.Font.Name = "Cambria"
        .Columns.Font.Size = 18
        
         'تنسيق مخصص لكل عمود
        For n = 1 To 9    
            Select Case n
                Case 1
                    .Columns(n).NumberFormat = "###0"
                Case 2
          CODE..........
              ..........
                  
            End Select
             ' إظافة التنسيقات 
            .Columns(n).ColumnWidth = ColArr(n - 1)
            .Columns(n).HorizontalAlignment = xlCenter
            .Columns(n).VerticalAlignment = xlCenter
        Next n
        'تنسيق الصفوف
        For i = 2 To lastRow - 6
            dest.Rows(i).RowHeight = WS.Rows(i + 5).RowHeight
        Next i
    End With

 

Book2.xlsm

[ناصرالمصرى]

أعتقد أخى محمد أن الكود الخاص بكم يحتوى على العديد من العمليات الحسابية

التى بدأت من خلاله فهم المنطق الذى يحتويه من أفكار لكن هناك نقطة لم أتوصل إليها

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

برجاء ملاحظة الصوره أدناه مع ملاحظة الصف الأول ذات اللون الرمادى هذا كل شيىء

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

مرة اخرى شاكر فضل حضرتك لصبرك معى وجزاكم الله خيرا

[محمد هشام.]

هل تقصد هدا

[ناصرالمصرى]

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

لا أقصد هذا **** ما أقصده هو أن رؤوس الأعمدة فى الصف الأول بداية من ال A1 والبيانات فى الصف الثانى بداية من ال A2 دون ترقيم للأعمدة

الترقيم ما هو إلا لتحديد الأعمدة المراد نقلها من الورقة DATA إلى الورقةSummary  فقط ليس إلا

مرة أخرى نشكركم على طيب إخلاقكم الكريمة وجزاكم الله خيرا

 

[محمد هشام.]

نعم ليس هناك  اي ترقيم هدا فقط نسخ للقيم الموجودة على الورقة  DATA  في الصف الأول 

أظن انك تقصد هدا 

تم تعديل نوفمبر 10 بواسطه محمد هشام.

[ناصرالمصرى]

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

[محمد هشام.]

Sub CopyData()
    Dim ColArr(1 To 9) As Long
    Dim WS As Worksheet, dest As Worksheet
    Dim a As Range, n As Integer, lastRow As Long
    
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    Set WS = Sheets("DATA")
    Set dest = Sheets("Summary")

    lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row
    If lastRow < 7 Then Exit Sub

    dest.Range("A1:I" & dest.Cells(dest.Rows.Count, 1).End(xlUp).Row).Clear

    dest.Range("A1").Resize(lastRow - 6, 9).Value = WS.Range("A7:I" & lastRow).Value

    ColArr(1) = 30
    ColArr(2) = 23
    ColArr(3) = 22
    ColArr(4) = 13
    ColArr(5) = 18
    ColArr(6) = 16
    ColArr(7) = 25
    ColArr(8) = 30
    ColArr(9) = 20
 With dest
        .Columns.Font.Name = "Cambria"
        .Columns.Font.Size = 18
    For n = 1 To 9
        Set a = dest.Range(dest.Cells(2, n), dest.Cells(lastRow, n))
        Select Case n
            Case 1: a.NumberFormat = "###0"
            Case 2: a.NumberFormat = "#,##0"
            Case 3: a.NumberFormat = "#,##0.00"
            Case 4: a.NumberFormat = "0.00%"
            Case 5: a.NumberFormat = "@"
            Case 6: a.NumberFormat = "dd/mm/yyyy"
            Case 7: a.NumberFormat = "$#,##0.00"
            Case 8: a.NumberFormat = "0.00%"
            Case 9: a.NumberFormat = "General"
        End Select
    Next n

    For n = 1 To 9
        dest.Columns(n).ColumnWidth = ColArr(n)
        dest.Columns(n).HorizontalAlignment = xlCenter
        dest.Columns(n).VerticalAlignment = xlCenter
    Next n

    dest.Rows(1).RowHeight = WS.Rows(7).RowHeight
 End With
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True

End Sub

 

 

تم تعديل نوفمبر 10 بواسطه محمد هشام.

[ناصرالمصرى]

بارك الله فيكم وجزاكم الله خير الجزاء

هناك بعض الرسائل الغير مرغوب فيها

هل هناك خطأ فى الإعلان عن المتغيرات

تم تعديل نوفمبر 10 بواسطه ناصرالمصرى

[محمد هشام.]

اخي الكود يشتغل معي بدون مشاكل كما في الصورة المرفقة 

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

 

 

Book2 v2.xlsm

[ناصرالمصرى]

تمام بارك الله فيك وجزاكم الله خيرا

المشكلة هى عدم الإعلان عن المتغيرات بإضافة Option Explicit لتحديد نوع المتغيرات فقط لا غير

شاكر فضل حضرتك على ما قدمته فى هذا الموضوع

تقبل وافر التحية والتقدير