كود ترحيل أعمدة معينة

**محمدي عبد السميع** · مايو 5, 2012

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

الحمد لله الواحد القهار، العزيز الغفار، مكور الليل على النهار ،

تذكرة لأولي القلوب والأبصار وتبصرة لذوي الألباب والاعتبار ،

الذي أيقظ من خلقه من اصطفاه فزهدهم في هذه الدار،

وشغلهم بمراقبته وإدامة الأفكار ،

وملازمة الاتعاظ والادكار،

ووفقهم للدؤوب في طاعته والتأهب لدار القرار،

والحذر مما يسخطه ويوجب دار البوار،

والمحافظة على ذلك مع تغاير الأحوال والأطوار.

أحمده أبلغ حمد وأزكاه، وأشمله وأنماه.

أما بعد:

رأيت أن أقدم عملا خالصا لوجه الله الكريم لعل الله يتغمدنا برحمته

ولذا رأيت أنا الفقير إلى الله المحمدي عبد السميع عبد الغني أن أجمع الأكواد بطريقة منظمة تسهل للجميع الحصول عليها عند استخدام محرك البحث ،

ولهذا ساقدم

سلسلة من الأكواد كل كود بعنوان واضح يسهل الوصول له

في موضوع مستقل

وسأشرح كيفية استخدام الكود ماتيسر لي

إن شاء الله

وعلى الله قصد السبيل

******************************************

هذا

كود ترحيل أعمدة معينة

في هذا الكود سيتم

ترحيل الأعمدة الموجودة في الصفحة المصدر ( الشيت )

ويمكن تغييرها الى أي أعمدة تبغاها

("a1:c1,z1,ai1,ar1,ba1,bl1,bm1,cd1,di1,dj1").

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

افتح ملف اكسيل

اضغط على الرز ALT وانت ضاغط على الزر

اضغط على F11 الموجود أعلا لوحة المفاتيح

ستظهر شاشة الماكرو

اضغط على موديول 1

سيتم فتح الموديول

الصق فيه الكود الموجود

تحت هذا السطر

[/center]





'''   هذا الكود للعالم العلامة / عبد الله باقشير

Sub KH_START1()

Dim R As Integer, M As Integer, N As Integer

Sheets("كشف ناجح").Range("B7:Es1000").ClearContents

Sheets("كشف الدور الثاني").Range("B7:Es1000").ClearContents


    '''  عدد الصفوف العليا في الصفحات المنقول اليها البيانات

    M = 6: N = 6: S = 6

    Application.ScreenUpdating = False


	    '''  بداية ونهاية صفوف الورقة المصدر

		 For R = 11 To 700


			 ''' رقم عمود المعيار وكلمة المعيار

			  If Cells(R, 113) = "ناجح" Then

				 M = M + 1


		    '''  أسماء الأعمدة المطلوب نسخها

	 Range("A" & R).Range("a1:c1,z1,ai1,ar1,ba1,bl1,bm1,cd1,di1,dj1").Copy


			    '''  سيتم اللصق في هذا الشيت

			 With Sheets("كشف ناجح")


				   '''  سيتم اللصق بدءا من عمود

			 .Range("B" & M).PasteSpecial xlPasteValues

			 .Range("B" & M).PasteSpecial xlPasteFormats

			 .Range("B" & M) = M - 6

				    End With

					  Application.CutCopyMode = False


						 '''    للصفحة الأخرى المطلوب الترحيل إليها

						  'رقم عمود المعيار وكلمة المعيار

				 ElseIf Cells(R, 113) = "دور ثان في" Then


						 '''  لترك صف اعلا كل صف

				   N = N + 2


									   '''  أسماء الأعمدة المطلوب نسخها

	 Range("A" & R).Range("a1:c1,z1,ai1,ar1,ba1,bl1,bm1,cd1,di1,dj1").Copy


							 '''  سيتم اللصق في هذا الشيت

	 With Sheets("كشف الدور الثاني")


		   .Range("B" & N).PasteSpecial xlPasteValues

		   .Range("B" & N).PasteSpecial xlPasteFormats

		   .Range("B" & N) = (N - 6) / 2

				 End With

			 Application.CutCopyMode = False

			 End If

    Next

    MsgBox "تم ترحيل   " & M - 6 & "   طالب ناجح" & Chr(10) & Chr(10) & _

    "تم ترحيل   " & (N - 6) / 2 & "   طالب دور ثاني", vbMsgBoxRight, "الحمدلله"

    Application.ScreenUpdating = True


End Sub

ودمتم في حفظ الله

ترحيل مفيد باختبار اعمدة معينة.rar

HAMEED MAJEED · يناير 4, 2013

بارك الله فيك استاذنا

**حمادة عمر** · يناير 4, 2013

السلام عليكم

الاستاذ / محمد عبد السميع

جزاك الله خير واعطاء الاجر والثواب علي تقديمك العون للاعضاء والتسهيل عليهم للحصول علي المعلومات والاكواد

والأكيد اننا كلنا يجب علينا ان نقدم الشكر الواجب والعرفان للاستاذ القدير / عبد الله باقشير صاحب هذه الابداعات

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

**جلال محمد** · يناير 4, 2013

اخي الكريم محمد عبد السميع

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

وجزي الله عالمنا الكبير عبد الله باقشير كل خير

وشكرا جزيلا علي الشرح الجميل الذي يسهل علينا الكثير والكثير

المصرى ادم · يناير 18, 2013

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

**ا بو سليمان** · أبريل 5, 2014

احسنت

.

غالب عبد · أبريل 5, 2014

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

**ناصر سعيد** · مايو 26, 2015

ترحيل بيانات بالقائمة المنسدلة للعلامه عبد الله باقشير

ترحيل عن طريق القائمة المنسدله.rar

**قصي** · يونيو 5, 2015

استدعاء بيانات حفظ الله كل من ساهم فيها

ترحيل مفيد باختبار اعمدة معينة 2. rar 76.42 كيلو 600 عدد مرات التحميل



Sub Nageh_Raseb()
'يقوم الكود بترحيل الناجحين والراسبين في أوراق العمل المخصصة لذلك
'----------------------------------------------------------------
'تعريف المتغيرات
    Dim RowNageh As Long, RowRaseb As Long
    Dim WS As Worksheet, SHNageh As Worksheet, SHRaseb As Worksheet

'تعيين متغيرات أوراق العمل
    Set WS = Sheets("الشيت"): Set SHNageh = Sheets("كشف ناجح"): Set SHRaseb = Sheets("كشف الدور الثاني")

'مسح محتويات النطاق الذي سيتم الترحيل إليه في ورقة الناجحين
    SHNageh.Range("C7:M1000").ClearContents

'مسح محتويات النطاق الذي سيتم الترحيل إليه في ورقة الراسبين
    SHRaseb.Range("C7:M1000").ClearContents

'صف البداية الذي سيتم الترحيل إليه في ورقة الناجحين وورقة الراسبين
    RowNageh = 7: RowRaseb = 7

'إلغاء خاصية اهتزاز الشاشة
    Application.ScreenUpdating = False

'حلقة تكرارية في ورقة البيانات الأساسية بداية من الصف رقم 11 حتى آخر صف
        For R = 11 To WS.Cells(Rows.Count, 1).End(xlUp).Row

'يمثل الرقم 113 رقم العمود الذي به النتيجة في ورقة البيانات الأساسية
'إذا كانت الخلية في الصف المحدد في عمود النتيجة تساوي كلمة ناجح
            If Cells(R, 113) = "ناجح" Then

'نسخ النطاقات المحددة في الصف المحدد في حالة تحقق الشرط
                WS.Range("A" & R).Range("B1:C1,Z1,AI1,AR1,BA1,BL1,BM1,CD1,DI1,DJ1").Copy

'لصق البيانات المنسوخة إلى العمود الثالث في ورقة الناجحين
                SHNageh.Range("C" & RowNageh).PasteSpecial xlPasteValues

'إلغاء خاصية القص والنسخ
                Application.CutCopyMode = False

'زيادة المتغير بمقدار واحد استعداداً لبيانات جديدة
                RowNageh = RowNageh + 1

'إذا كانت الخلية في الصف المحدد في عمود النتيجة تساوي كلمة دور ثان في
            ElseIf Cells(R, 113) = "دور ثان في" Then

'نسخ النطاقات المحددة في الصف المحدد في حالة تحقق الشرط
                WS.Range("A" & R).Range("B1:C1,Z1,AI1,AR1,BA1,BL1,BM1,CD1,DI1,DJ1").Copy

'لصق البيانات المنسوخة إلى العمود الثالث في ورقة الراسبين
                SHRaseb.Range("C" & RowRaseb).PasteSpecial xlPasteValues

'إلغاء خاصية القص والنسخ
                Application.CutCopyMode = False

'زيادة المتغير بمقدار واحد استعداداً لبيانات جديدة
                RowRaseb = RowRaseb + 1
            End If

'الانتقال للصف التالي في ورقة البيانات الأساسية
        Next

'رسالة تفيد بانتهاء عملية الترحيل
        MsgBox ("الحمد لله تم ترحيل الناجحين و الراسبين إلى أوراق عمل جديدة"), vbInformation

'إعادة تفعيل خاصية اهتزاز الشاشة
    Application.ScreenUpdating = True

السلام عليكم

نعدل الشرط للبحث عن جزء من الكلمة "دور ثان" وسينفذ الكود مهما اضاف قبلها او بعدها (له او لها)

ElseIf InStr(1, Cells(R, 113).Value, "دور ثان") Then

مكان

ElseIf Cells(R, 113) = "دور ثان في" Then

حفظ الله كل من ساهم فيها

**ناصر سعيد** · يونيو 13, 2016

Sub KH_START()


Dim b As Integer, M As Integer
    
    Sheets("كشف ناجح").Range("c7:m1000").ClearContents
        
        Sheets("كشف الدور الثاني").Range("c7:m1000").ClearContents
                    M = 7: b = 7
        Application.ScreenUpdating = False
    For R = 1 To 1000
            If InStr(1, Sheets("الشيت").Cells(R, 113).Value, "ناجح") Then
            Sheets("الشيت").Range("A" & R).Range("b1:c1,z1,ai1,ar1,ba1,bl1,bm1,cd1,di1,dj1").Copy
            Sheets("كشف ناجح").Range("c" & M).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            M = M + 1
            End If
            If InStr(1, Sheets("الشيت").Cells(R, 113).Value, "دور ثان") Then
                Sheets("الشيت").Range("A" & R).Range("b1:c1,z1,ai1,ar1,ba1,bl1,bm1,cd1,di1,dj1").Copy
                Sheets("كشف الدور الثاني").Range("c" & b).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            b = b + 1
            End If
    Next
  
    MsgBox ("الحمد لله تـــم ترحيل الناجحين و الراسبين إلى أوراق عمل جديدة ")
    Application.ScreenUpdating = True
End Sub

كود استدعاء رائع بتحسينات الاستاذ المحترم اسامه البراوي حفظه الله

ترحيل مفيد باختبار اعمدة معينة 2.

تم تعديل يونيو 13, 2016 بواسطه ناصر سعيد
تكبير الخط

asdhamdey · يونيو 30, 2016



Sub Tarhil_Ragab()
    'تعريف المتغيرات
    Dim Sh As Worksheet
    Dim strSh As String
    Dim I As Long
    Dim AA As Long

    'سطر لإيقاف تحديث الشاشة
    Application.ScreenUpdating = False
    
        'مسح محتويات النطاق في ورقة العمل ناجح
        Sheets("ناجح").Range("A12:X1000").ClearContents
    
        'مسح محتويات النطاق في ورقة العمل دور ثان
        Sheets("دور ثان").Range("A12:X1000").ClearContents
    
        'مسح محتويات النطاق في ورقة العمل راسب
        Sheets("راسب").Range("A12:X1000").ClearContents
    
        'بدء التعامل مع ورقة العمل الأولى التي تعتبر الورقة الرئيسية
        With Sheet1
        
            '[Y] حلقة تكرارية بدايةً من الصف الـ 12 وحتى آخر صف به بيانات بالاعتماد على العمود
            For I = 12 To .Cells(10000, "Y").End(xlUp).Row
    
                '[Y] تعيين قيمة المتغير ليساوي قيمة الخلية في الصف المحدد في العمود
                'ففي أول حلقة تكرارية سيكون الصف هو رقم 12 [I] المقصود بالصف المحدد الصف الذي يحمل قيمة المتغير
                'وفي الحلقة التالية سيكون الصف رقم 13 وهكذا مع كل حلقة تكرارية يتغير الصف
                strSh = .Cells(I, "Y").Value
    
                'تعيين المتغير ليساوي آخر صف في الورقة التي سيتم الترحيل إليها
                'أو يمكنك القول معرفة رقم صف أول صف فارغ
                AA = Sheets(strSh).Cells(10000, 2).End(xlUp).Row + 1
    
                'إذا كان المتغير أقل من 12 الذي من المفترض أنه صف البداية لعمليات الترحيل فإنه يتم تعيين المتغير ليساوي 12
                If AA < 12 Then AA = 12
    
                'في حالة حدوث خطأ يتم تجنبه بهذا السطر
                On Error Resume Next
    
                'نسخ النطاق في الصف المحدد من العمود الثاني إلى العمود الرابع والعشرون
                .Range(.Cells(I, "B"), .Cells(I, "X")).Copy
    
                'لصق النطاق المنسوخ إلى ورقة العمل المناسبة واللصق يكون لصق قيم فقط
                Sheets(strSh).Range("B" & AA).PasteSpecial xlPasteValues
    
                'إلغاء خاصية النسخ واللصق
                Application.CutCopyMode = False
    
                'هذا السطر يقوم بترقيم الصف الذي تم ترحيله في الورقة الهدف
                'حيث يعتمد على إنقاص 11 من رقم الصف الحالي
                'فإذا كان الصف الحالي هو رقم 12 ألا وهو رقم البداية فإن الرقم
                'المسلسل سيكون 12 - 11 أي سيكون الرقم المسلسل 1
                Sheets(strSh).Cells(AA, "A").Value = Sheets(strSh).Cells(AA, "A").Row - 11
    
                'الانتقال للصف التالي في الحلقة التكرارية
            Next I
    
            'حلقة تكرارية لكل أوراق العمل لتحديد الخلية الأولى في ورقةالعمل
            For Each Sh In ThisWorkbook.Worksheets
                Application.Goto Sh.Range("A1")
            Next Sh
    
            'تنشيط ورقة العمل الأولى
            .Activate
    
        'انتهاء التعامل مع ورقة العمل الأولى
        End With
        
    'سطر لإعادة تفعيل اهتزاز الشاشة
    Application.ScreenUpdating = True

    'إظهار رسالة تفيد بانتهاء عمل الكود
    MsgBox "تم الفصل بنجاح", 64
End Sub

ابن بنها · نوفمبر 29, 2016

ملف رائع للعلامه عبد الله باقشير

لاستخراج طلاب الدور التاني

في كشف مناداه الدور التاني

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

http://up.top4top.net/downloadf-3331mdfr1-rar.html

**ناصر سعيد** · ديسمبر 11, 2016

ترحيل او استدعاء راءع


'''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''
Sub NAGEH()
''هذا الكود للعبقري ياسر العربي حفظه الله
'' تم هذا الكود بتاريخ 8 / 10/ 2016
''الهدف من الكود هو استدعاء بيانات
''شرح الكود
''
    Dim myArray, lr, X, targt, targt1, targt2, targtN
    Dim SERCH As Worksheet, DATA As Worksheet
    '____________________________________________
    Set DATA = Worksheets("رصد الترم الثانى")    'اسم شيت  المصدر
    Set SERCH = Worksheets("كشف ناجح")    'اسم الشيت الهدف
    '____________________________________________
    Range("A8:R1000").Clear
    'النطاقات متغيره
    Range("B7:R7").AutoFill Destination:=Range("B7:R" & Range("A4").Value + 6), Type:=xlFillDefault
    lr = DATA.Cells(Rows.Count, 2).End(xlUp).Row + 2  'اخر صف به بيانات
    'رقم عمود البدايه اللي بعد المسلسل
  '  متغير
    SERCH.Range("C7:N" & SERCH.Cells(Rows.Count, 3).End(xlUp).Row + 1).ClearContents    'مسح نطاق البحث القديم
    targt = "له* دور ثان في"    'معيار البحث
    
     'نطاق قاعدةالبيانات المصدر الذي سيتم البحث فيه
    myArray = DATA.Range("A7:EF" & lr)
    '____________________________________________
    'عدد الاعمده في الجدول في صفحه الهدف
    ReDim Y(1 To lr, 1 To 13)
    For X = 1 To lr - 6
        If targt = "" Then Exit Sub
        
        'رقم عمود معيار البحث
        If myArray(X, 101) Like targt & "*" Then
            rw = rw + 1
            'For ww = 1 To 102
              '  Y(rw, ww) = myArray(X, ww)
          '  Next ww
    'العمود التاني بعد المسلسل
          Y(rw, 1) = myArray(X, 2)
          
              'العمود الثالث بعد المسلسل
          Y(rw, 2) = myArray(X, 3)
          
              'العمود الرابع بعد المسلسل
          Y(rw, 3) = myArray(X, 13)
          
              'العمود الخامس بعد المسلسل
          Y(rw, 4) = myArray(X, 22)
          
              'العمود السادس بعد المسلسل وهكذا
          Y(rw, 5) = myArray(X, 31)
          
          Y(rw, 6) = myArray(X, 40)
          Y(rw, 7) = myArray(X, 51)
          Y(rw, 8) = myArray(X, 52)
          Y(rw, 9) = myArray(X, 82)
          Y(rw, 10) = myArray(X, 101)
          Y(rw, 11) = myArray(X, 102)
        '  Y(rw, 12) = myArray(X, 110)
         ' Y(rw, 13) = myArray(X, 111)
        End If
Next X
If rw > 0 Then SERCH.Cells(Rows.Count, 3).End(xlUp)(2, 1).Resize(rw, 13).Value = Y()
End Sub

ترحيل الدور التاني5.rar

**ناصر سعيد** · ديسمبر 11, 2016

==========================================================

كود طباعه

Sub MyPrnt()
'
Beep
If MsgBox("هل تريد الطباعة", vbYesNo, "تنبية") = vbYes Then
    ActiveWindow.SelectedSheets.PrintOut Copies:=1
 End If

End Sub
'******************
Sub معاينه_طباعه()

    Dim SS As Integer
    
    ''من كنوز العلامة عبد الله باقشير
   ' SS = Range("عدد_الأوراق").Value * [AK2]
    SS = Range("B" & Rows.Count).End(xlUp).Row
     Range("A2:J" & SS).RowHeight = 24

    ActiveSheet.PageSetup.PrintArea _
    = "$A$2:$J$" & SS
    ActiveWindow.SelectedSheets.PrintOut Copies:=1
   ' PrintPreview
    'PrintOut Copies:=1
    [A7].Select
End Sub

**ناصر سعيد** · ديسمبر 11, 2016

الملف

طباعـــــــــــــه صفحات.rar

**ناصر سعيد** · مايو 4, 2017

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

للنابغه ياسر خليل



Option Explicit
'هذا الكود للمحترم النابغه ياسر خليل
'الهدف من الكود هو ترحيل بشرط
'تم هذا الكود في 15/2/2017
Sub UsingArrays()
    Dim arr     As Variant
    Dim temp    As Variant
    Dim lr      As Long
    Dim i       As Long
    Dim j       As Long
    Dim c       As Long
    
    'متغير اسم ورقة المصدر
    lr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    
        'متغير اسم ورقة المصدرومدى البيانات بها
    arr = Sheets("Sheet1").Range("A2:C" & lr).Value
    ReDim temp(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    j = 1
    
    For i = LBound(arr, 1) To UBound(arr, 1)
    
        ' المعيار او الشرط الذي نبحث به
        If arr(i, 3) Like "*" & "P" & "*" Then
       
            For c = LBound(arr, 2) To UBound(arr, 2)
                temp(j, c) = arr(i, c)
            Next c
            j = j + 1
        End If
    Next i
    
       'متغير اسم ورقة الهدف واسم الخليه التي سيتم ترحيل العناوين اليها
   Sheets("Sheet2").Range("E5").Resize(, UBound(temp, 2)).Value = Array("Names", "Marks", "Status")
   
       'متغير اسم ورقة الهدف واسم الخليه التي سيتم الترحيل اليها
    Sheets("Sheet2").Range("E6").Resize(j - 1, UBound(temp, 2)).Value = temp
End Sub

استدعاء بشرط.

**ناصر سعيد** · مايو 5, 2017

ترحيل اعمده معينه لاعمده اخرى في شيت اخر معينه

Option Explicit
'هذا الكود للمحترم النابغه ياسر خليل
'الهدف من الكود هو ترحيل اعمده معينه لاعمده اخرى معينه
'تم هذا الكود في 15/2/2017
Sub Test()
    Dim arr     As Variant
    Dim i       As Variant
    Dim cr      As Variant
    Dim j       As Long
    Dim lr      As Long
    
     'متغير اسم ورقة المصدر
    lr = Sheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row
    
     'متغير اسم ورقة المصدرومدى البيانات بها
   arr = Sheets("Sheet1").Range("A1:K" & lr).Value
   
    'الأعمدة المطلوب الترحيل إليها
    cr = Array(3, 5, 9)
    
    'أرقام الأعمدة المطلوب ترحيلها
    For Each i In Array(2, 6, 10)
        Sheets("Sheet2").Cells(1, cr(j)).Resize(UBound(arr, 1)).Value = Application.Index(arr, , i)
        j = j + 1
    Next i
End Sub

استدعاء اعمد معينه لاعمده اخرى معينه.rar

**ناصر سعيد** · مايو 6, 2017

رايط شرح كود استدعاء بيانات اعمده متفرقه لاعمده معينه اخرى

===============

شرح الكود السابق

ياسر خليل أبو البراء · مايو 6, 2017

جزاك الله خيراً أخي العزيز ناصر على حرصك لنشر العلم .. تقبل وافر تقديري واحترامي

**ناصر سعيد** · مايو 7, 2017

الكود بعد اضافه سطر مسح البيانات المرحله ومسح التسطير



Option Explicit

Sub Test()
'هذا الكود للمحترم النابغه ياسر خليل
'الهدف من الكود هو ترحيل اعمده معينه لاعمده اخرى معينه بالتسطير
'تم هذا الكود في 6/5/2017
'متغيرات
    Dim arr     As Variant
    Dim i       As Variant
    Dim cr      As Variant
    Dim j       As Long
    Dim lr      As Long
  'سطر لمسح النطاق
 Range("A4:Z1000").Clear
 lr = Sheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row

'اسم شيت المصدر واسم الخليه الاولى منه
 arr = Sheets("Sheet1").Range("A7:K" & lr).Value
    
    'الأعمدة المطلوب الترحيل إليها
    cr = Array(3, 5, 7)
    
    'أرقام الأعمدة المطلوب ترحيلها
    For Each i In Array(1, 3, 5)
    
    'اسم شيت الهدف ورقم صف صفحة الهدف
   Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Value = Application.Index(arr, , i)
   
   'سطر لمسح التسطير
   Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Borders.Value = 0
   
   'سطر للتسطير
   Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Borders.Value = 1

        j = j + 1
    Next i
End Sub

**ناصر سعيد** · مايو 7, 2017

Option Explicit

Sub Test()
'هذا الكود للمحترم النابغه ياسر خليل
'الهدف من الكود هو ترحيل اعمده معينه لاعمده اخرى معينه بالتسطير
'تم هذا الكود في 6/5/2017
'متغيرات
    Dim arr     As Variant
    Dim i       As Variant
    Dim cr      As Variant
    Dim j       As Long
    Dim lr      As Long
  'سطر لمسح النطاق
 Range("A4:Z1000").ClearContents
 lr = Sheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row

'اسم شيت المصدر والمدى منه
 arr = Sheets("Sheet1").Range("A7:K" & lr).Value
    
    'الأعمدة المطلوب الترحيل إليها
    cr = Array(3, 5, 7)
    
    'أرقام الأعمدة المطلوب ترحيلها
    For Each i In Array(1, 3, 5)
    
    'اسم شيت الهدف ورقم صف صفحة الهدف
   Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Value = Application.Index(arr, , i)
   
   'سطر لمسح التسطير
   Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Borders.Value = 0
   
   'سطر للتسطير
   Sheets("Sheet2").Cells(4, cr(j)).Resize(UBound(arr, 1)).Borders.Value = 1

        j = j + 1
    Next i
End Sub

كود استدعاء بيانات اعمده متفرقه لاعمده اخرى متفرقه في اخر تحسيناته

**ناصر سعيد** · مايو 7, 2017

Option Explicit
'هذا الكود للمحترم النابغه ياسر خليل
'الهدف من الكود هو ترحيل بشرط
'تم هذا الكود في 15/2/2017
Sub UsingArrays()
    Dim arr     As Variant
    Dim temp    As Variant
    Dim lr      As Long
    Dim i       As Long
    Dim j       As Long
    Dim c       As Long
   Sheets("Sheet2").Range("A4:Z1000").ClearContents
    
    'متغير اسم ورقة المصدر
    lr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    
        'متغير اسم ورقة المصدرومدى البيانات بها
    arr = Sheets("Sheet1").Range("A2:C" & lr).Value
    ReDim temp(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    j = 1
    
    For i = LBound(arr, 1) To UBound(arr, 1)
    
        ' المعيار او الشرط الذي نبحث به
        If arr(i, 3) Like "*" & "نا*" & "*" Then
       
            For c = LBound(arr, 2) To UBound(arr, 2)
                temp(j, c) = arr(i, c)
            Next c
            j = j + 1
        End If
    Next i
    
       'متغير اسم ورقة الهدف واسم الخليه التي سيتم ترحيل العناوين اليها
  Sheets("Sheet2").Range("E5").Resize(, UBound(temp, 2)).Value = Array("الاسماء", "الدرجات", "الحالة")
      
       'متغير اسم ورقة الهدف واسم الخليه التي سيتم الترحيل اليها
  Sheets("Sheet2").Range("E6").Resize(j - 1, UBound(temp, 2)).Value = temp
  
  'سطر لمسح التسطير
  Sheets("Sheet2").Range("E5:G" & Rows.Count).Borders.Value = 0
 
 'سطر لاضافة التسطير
  Sheets("Sheet2").Range("E6").CurrentRegion.Borders.Value = 1
End Sub

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

استدعاء بشرط.rar

**ناصر سعيد** · نوفمبر 14, 2017

=========================

الملف الجامع لهذه الاكواد ( اكواد الاستدعاء )

استدعاء بمعيارين من الخارج3.rar

**ناصر سعيد** · نوفمبر 20, 2017

هاشم بركات · مايو 28, 2018

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

اللهم اجعل هذه الاعمال في ميزان حسناتهم

تسجيل الدخول

كود ترحيل أعمدة معينة

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

محمدي عبد السميع

HAMEED MAJEED

حمادة عمر

جلال محمد

المصرى ادم

ا بو سليمان

غالب عبد

ناصر سعيد

قصي

ناصر سعيد

asdhamdey

ابن بنها

ناصر سعيد

ناصر سعيد

ناصر سعيد

ناصر سعيد

ناصر سعيد

ناصر سعيد

ياسر خليل أبو البراء

ناصر سعيد

ناصر سعيد

ناصر سعيد

ناصر سعيد

ناصر سعيد

هاشم بركات

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information