أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
EM_ACC مجدى يونس-- لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة بحاجة الى كود ترحيل اكسيل اسئله واجابات


أهلا وسهلا بك زائرنا الكريم في أكاديمية الصقر للتدريب، لكي تتمكن من المشاركة ومشاهدة جميع أقسام المنتدى وكافة الميزات ، يجب عليك إنشاء حساب جديد بالتسجيل بالضغط هنا أو تسجيل الدخول اضغط هنا إذا كنت عضواً .





نسخ و لصق جدول معكوسا

السلام عليكم و رحمة الله و بركاته عندي الجدول 1 قاعدة بيانات كبيرة و اريد هذه البيانات تحويلها غلى الجدول 2 مع تغيير موا ..


موضوع مغلق


23-06-2022 07:00 مساء
noureddine70
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 10-03-2019
رقم العضوية : 11894
المشاركات : 73
الدولة : الجزائر
الجنس : ذكر
تاريخ الميلاد : 6-12-1970
يتابعهم : 7
يتابعونه : 0
قوة السمعة : 103
 offline 

السلام عليكم و رحمة الله و بركاته
عندي الجدول 1 قاعدة بيانات كبيرة و اريد هذه البيانات تحويلها غلى الجدول 2 مع تغيير مواقع الخلايا اي تكون البيانات معكوسة من الاخيرة الى الاولى مع تجاهل الفراغات كما هو مبين في الملف 
سواءا بالمعادلات او الاكواد الفيجوال VBA
و جزاكم الله خيرا
 
 
  Copier_Coller.xlsx   تحميل xlsx مرات التحميل :(7)
الحجم :(12.905) KB



أفضل إجابة مقدمة من YasserKhalil وهي:
جرب الكود التالي عله يفي بالغرض بإذن الله
Sub Test()
    Dim a, e, v, x, rng As Range, i As Long, ii As Long
    Set rng = Range("B2:J6")
    rng.Copy Range("B23")
    With Range("B23")
        .Resize(rng.Rows.Count, 5).NumberFormat = "@"
        .Offset(, 5).Resize(rng.Rows.Count, 5).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
        a = .CurrentRegion.Value
    End With
    For i = LBound(a) To UBound(a)
        For Each e In Array(Array(2, 3, 4, 5), Array(6, 7, 8, 9))
            x = Application.Index(a, i, e)
            v = ReverseArray(x)
            If UBound(v) > 0 Then
                For ii = LBound(v) To UBound(v)
                    a(i, ii + e(0)) = v(ii)
                Next ii
            End If
        Next e
    Next i
    With Range("B23")
        .Resize(UBound(a, 1), UBound(a, 2)).Value = a
    End With
End Sub

Function ReverseArray(ByVal arr)
    Dim v
    With CreateObject("System.Collections.ArrayList")
        For Each v In arr
            If v <> Empty Then .Add v
        Next v
        .Reverse
        ReverseArray = .Toarray
    End With
End Function
عرض الإجابة




24-06-2022 11:51 صباحا
مشاهدة مشاركة منفردة [1]
حسين مامون
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 23-08-2017
رقم العضوية : 69
المشاركات : 172
الجنس : ذكر
الدعوات : 1
يتابعهم : 5
يتابعونه : 12
قوة السمعة : 957
عدد الإجابات: 22
 offline 
look/images/icons/i1.gif نسخ و لصق جدول معكوسا
هذه تجربة متواضعة لعلها فكرة عما تريد
Option Explicit

Sub test()
Dim firstX, lastX
Dim Y
Y = 10
firstX = 6
Application.ScreenUpdating = False
Do
If Y = 14 Then Exit Sub
Cells(firstX, "c").Resize(, 8).Copy
Range("c" & Y).PasteSpecial
Application.CutCopyMode = False

firstX = firstX - 1
Y = Y + 1
Loop
Application.ScreenUpdating = True

End Sub

 
 
  Copier_Coller.xlsm   تحميل xlsm مرات التحميل :(3)
الحجم :(21.12) KB


24-06-2022 12:47 مساء
مشاهدة مشاركة منفردة [2]
noureddine70
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 10-03-2019
رقم العضوية : 11894
المشاركات : 73
الدولة : الجزائر
الجنس : ذكر
تاريخ الميلاد : 6-12-1970
يتابعهم : 7
يتابعونه : 0
قوة السمعة : 103
 offline 
look/images/icons/i1.gif نسخ و لصق جدول معكوسا
بارك الله فيك و جزاك الله خيرا
و لكن طلبي ان يبقى الجدول محافظ على هيئته اي العمود B يبقى كما هو
لكن مثلا قيمة الخلية F3 في الجدول 1 تكون هي قيمة الخلية C10 في الجدول الثاني
وقيمة الخلية E3 في الجدول 1  تكون هي قيمة الخلية D10 في الجدول الثاني
اما اذا كنت الخلية فارغة فيأخذ الخلية التي بعدها مثلا قيمة الخلية F4 فارغة  في الجدول 1 فتكون قيمة الخلية C11 هي قيمة الخلية E4 و بما أن الخلية E4 كذلك فارغة فتكون قيمة الخلية C11 هي فيمة الخلية D4  و هكذا 
و معذرة منكم و ارجو ان يكون الشرح مفهوم و جزاكم الله خيرا
و أنا بدوري سوف أعمل على الكود الذي ارسلته و أحاول التعديل فيه لعلي اجد الحل
و السلام عليكم و رحمة الله و بركاته

24-06-2022 06:03 مساء
مشاهدة مشاركة منفردة [3]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10439
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 0
يتابعونه : 533
قوة السمعة : 36372
عدد الإجابات: 252
 offline 
look/images/icons/i1.gif نسخ و لصق جدول معكوسا
جرب الكود التالي عله يفي بالغرض بإذن الله
Sub Test()
    Dim a, e, v, x, rng As Range, i As Long, ii As Long
    Set rng = Range("B2:J6")
    rng.Copy Range("B23")
    With Range("B23")
        .Resize(rng.Rows.Count, 5).NumberFormat = "@"
        .Offset(, 5).Resize(rng.Rows.Count, 5).NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
        a = .CurrentRegion.Value
    End With
    For i = LBound(a) To UBound(a)
        For Each e In Array(Array(2, 3, 4, 5), Array(6, 7, 8, 9))
            x = Application.Index(a, i, e)
            v = ReverseArray(x)
            If UBound(v) > 0 Then
                For ii = LBound(v) To UBound(v)
                    a(i, ii + e(0)) = v(ii)
                Next ii
            End If
        Next e
    Next i
    With Range("B23")
        .Resize(UBound(a, 1), UBound(a, 2)).Value = a
    End With
End Sub

Function ReverseArray(ByVal arr)
    Dim v
    With CreateObject("System.Collections.ArrayList")
        For Each v In arr
            If v <> Empty Then .Add v
        Next v
        .Reverse
        ReverseArray = .Toarray
    End With
End Function

25-06-2022 05:47 صباحا
مشاهدة مشاركة منفردة [4]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10439
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 0
يتابعونه : 533
قوة السمعة : 36372
عدد الإجابات: 252
 offline 
look/images/icons/i1.gif نسخ و لصق جدول معكوسا
الكود مجرب عندي ويعمل بشكل جيد
أعتقد المشكلة سببها هو النت فريم ورك 3.5 ... جرب تسطيبه ، وننتظر تجربة الكود من قبل بعض الأعضاء للتأكد من عمل الكود.

25-06-2022 10:27 مساء
مشاهدة مشاركة منفردة [5]
noureddine70
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 10-03-2019
رقم العضوية : 11894
المشاركات : 73
الدولة : الجزائر
الجنس : ذكر
تاريخ الميلاد : 6-12-1970
يتابعهم : 7
يتابعونه : 0
قوة السمعة : 103
 offline 
look/images/icons/i1.gif نسخ و لصق جدول معكوسا
السلام عليكم و رحمة الله و بركاته
معذرة لكم في الحقيقة الكود شغال 100/100 و هذا حسب الملف الذي ارسلته أنا فحاولت ان اغير هذا الكود على ملفي شخصي لانه فيه بيانات كبيرة فلم استطع و هذا بسبب عدم فهمي الكود و المعادلات التي فيه 
فلو تكرمت اخي ياسر او اي أحد ان يشرح لي هذا الكود حتى حتى يتسنى لي تغييره طبقا لملفي الشخصي و جزاكم الله خيرا
 

26-06-2022 04:02 صباحا
مشاهدة مشاركة منفردة [6]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10439
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 0
يتابعونه : 533
قوة السمعة : 36372
عدد الإجابات: 252
 offline 
look/images/icons/i1.gif نسخ و لصق جدول معكوسا
وعليكم السلام أخي الكريم
لفهم الكود حاول تتبع عمل الكود باستخدام مفتاح F8 من لوحة المفاتيح ومتابعة نافذة اللوكال لمعرفة المتغيرات والتغيرات التي تحصل فيها



الكلمات الدلالية
جدول ، معكوسا ،


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 06:29 صباحا