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

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

محمدي عبد السميع
 مشاركة

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

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

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

قام بنشر
قام بنشر

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

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

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

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

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

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

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

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

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

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

أما بعد:

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

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

ولهذا ساقدم

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

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

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

إن شاء الله

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

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

هذا

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

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

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

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

("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

  • Like 3
  • Thanks 2
رابط هذا التعليق
شارك
  • 7 months later...
حمادة عمر

حمادة عمر

قام بنشر
قام بنشر

السلام عليكم

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

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

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

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

رابط هذا التعليق
شارك
  • 2 weeks later...
  • 1 year later...
  • 1 year later...
  • 2 weeks later...
قصي

قصي

قام بنشر
قام بنشر

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

ترحيل مفيد باختبار اعمدة معينة 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

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

رابط هذا التعليق
شارك
  • 1 year later...
ناصر سعيد

ناصر سعيد

قام بنشر
قام بنشر (معدل) 
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.

 

تم تعديل بواسطه ناصر سعيد
تكبير الخط
  • Like 1
رابط هذا التعليق
شارك
  • 3 weeks later...
asdhamdey

asdhamdey

قام بنشر
قام بنشر 


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

 

p_102yila1.gif

  • Thanks 1
رابط هذا التعليق
شارك
  • 4 months later...
  • 2 weeks later...
ناصر سعيد

ناصر سعيد

قام بنشر
قام بنشر

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


'''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''
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

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

ناصر سعيد

قام بنشر
قام بنشر

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

كود طباعه 

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

 

  • Thanks 1
رابط هذا التعليق
شارك
  • 4 months later...
ناصر سعيد

ناصر سعيد

قام بنشر
قام بنشر

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

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



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

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

  • Like 1
  • Thanks 1
رابط هذا التعليق
شارك
ناصر سعيد

ناصر سعيد

قام بنشر
قام بنشر

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

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

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

ناصر سعيد

قام بنشر
قام بنشر

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



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

 

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

ناصر سعيد

قام بنشر
قام بنشر 
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

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

  • Thanks 1
رابط هذا التعليق
شارك
ناصر سعيد

ناصر سعيد

قام بنشر
قام بنشر 
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

  • Like 1
  • Thanks 1
رابط هذا التعليق
شارك
  • 6 months later...
  • 6 months later...
زائر
هذا الموضوع مغلق.
 مشاركة
الذهاب الي قائمه المواضيع

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

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

Important Information

  I accept