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

ترحيل أعمدة غير متجاورة لأعمدة غير متجاورة باستخدام المصفوفات (كود حصري)

ناصر سعيد

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

 مشاركة

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

ناصر سعيد

ناصر سعيد

قام بنشر
  • الكاتب
قام بنشر

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

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

 

***********

لماذا تاتي البيانات المرحله دائما محاذاتها ناحيه اليمين ؟

 

نريد محاذاتها في الوسط

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

ناصر سعيد

قام بنشر
  • الكاتب
قام بنشر

جزاك الله خيرا استاذ ياسر

هذا كودكم الخاص باستدعاء يبانات بشرط

اضفت عليه سطر لمسح المحتوى وسطر لمسح التسطير وسطر لوضع التسطير

ولكن لم يتم ضبط التسطير 

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
    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(UBound(temp, 1)).Borders.Value = 0
   
   'سطر للتسطير
   Sheets("Sheet2").Range("E6").Resize(UBound(temp, 1)).Borders.Value = 1
       'متغير اسم ورقة الهدف واسم الخليه التي سيتم الترحيل اليها
    Sheets("Sheet2").Range("E6").Resize(j - 1, UBound(temp, 2)).Value = temp
End Sub

لم يتم ضبط التسطير .. لماذا ؟

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

ناصر سعيد

قام بنشر
  • الكاتب
قام بنشر 
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

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

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

حسين مامون

قام بنشر
قام بنشر (معدل)

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

اولا اود ان اشكر استاذنا ياسر خليل ابو البراء

وكذلك الاستاذ ناصر سعيد

 

بعذ ادن الاخ ياسر خليل ابو البراء قمت بتعديل بسيط للكود يعني الكود يفلتر البيانات حسب الخلية  K5 في الشيت2 ولكن عند ادخال رقم  غير موجود في الخلية K5 تحدث مشاكل .

استاذ ياسر خليل  .... فضلا ما حل هذه المشكة ؟ 

 

 

' قمت بالغاء هذا السطر في الكود If arr(i, 3) Like "*" & "äÇ*" & "*" Then
      واضفت هذا السطر If arr(i, 1) = Range("k5") Then

بحث بشرط.rar

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

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

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

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

جرب التعديل التالي 

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("E6:H1000").Clear
    lr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    arr = Sheets("Sheet1").Range("A2:D" & 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, 4) = Range("K5") 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

    If j = 1 Then MsgBox "Invalid Criteria", vbExclamation: Exit Sub
    Sheets("Sheet2").Range("E5").Resize(, UBound(temp, 2)).Value = Array("الكود", "الأسماء", "الدرجات", "الحالة")
    Sheets("Sheet2").Range("E6").Resize(j - 1, UBound(temp, 2)).Value = temp
End Sub

 

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

حسين مامون

قام بنشر
قام بنشر
21 دقائق مضت, ياسر خليل أبو البراء said:

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

جرب التعديل التالي 


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("E6:H1000").Clear
    lr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    arr = Sheets("Sheet1").Range("A2:D" & 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, 4) = Range("K5") 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

    If j = 1 Then MsgBox "Invalid Criteria", vbExclamation: Exit Sub
    Sheets("Sheet2").Range("E5").Resize(, UBound(temp, 2)).Value = Array("الكود", "الأسماء", "الدرجات", "الحالة")
    Sheets("Sheet2").Range("E6").Resize(j - 1, UBound(temp, 2)).Value = temp
End Sub

 

 

اخي اشكرك على الاهتمام

جربت الكود لم يعد يعمل يبحث حتى على الارقام الموجودة في العمود a

في كل بحث يعطي رسالة "Invalid Criteria"

 

رابط هذا التعليق
شارك
ياسر خليل أبو البراء

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

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

اعتقدت أنك تبحث في عمود الحالة وليس العمود الأول .. عموماً لو شاهدت الفيديو الخاص بالكود يمكنك فهم كيفية عمل الكود بشكل أفضل

الحمد لله أن تم حل المشكلة

تقبل تحياتي

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

حسين مامون

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

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

استاذ ناصر سعيد

الف شكر لك اخي 

بخصوص الموضوع ليس لدي اي مرفق  فقط اعجبني كود الاخ ياسر خليل واردت الاستفاذة كغيري من محبي الاكسيل

تحياتي 

 

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

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

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

Important Information

  I accept