ترحيل البيانات اعتمادا على قيمة نصية

[أبو عبد الرحمن سعيد]

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

وبه نستعين

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

فى المثال التالى بورقة البيانات النطاق من A8  الى AR8  وحتى أخر صف به بيانات

فى العمود C  قائمة أسماء غير مرتبة 

فى العمود O قيمة نصية تحت اسم " أوفسينا " والتى على أساسها سيتم ترحيل البيانات

المطلوب بحول الله تعالى

ترحيل بيانات الاعمدة الملونة باللون الرمادى من ورقة البيانات الى ورقة النتائج

على أن تكون مؤبجدة وبنفس تنسيقات ورقة البيانات

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

شكرا لسعة صدركم وجزاكم الله خيرا ورزقنا وإياكم من حيث لانحتسب

تقبلوا وافر تقديرى واحترامى

 

 

 

 

 

 

ترحيل البيانات اعتمادا على قيمة نصية.rar

[سليم حاصبيا]

جرب هذا الكود

ليعمل الكود بشكل جيد يجب ازالة الخلايا المدمجة من صفحة البيانات  في الصف الاول

Sub Translate_Data()
 Dim rg_to_copy As Range
 Dim lr As Integer
 Dim m As Integer
 m = 0
 Application.ScreenUpdating = False
 On Error Resume Next
 Sheets("النتائج").Cells.ClearContents
 lr = Application.Max(Sheets("البيانات").Range("A:A"))
  For I = 1 To lr
   If Sheets("البيانات").Cells(I + 7, "O") = "اوفسينا" Then
   With Sheets("البيانات")
   .Select
    Set rg_to_copy = Union(.Range(Cells(I + 7, 1), Cells(I + 7, 4)), .Range(Cells(I + 7, 15), Cells(I + 7, 17)), _
    .Range(Cells(I + 7, 26), Cells(I + 7, 28)))
   End With
    rg_to_copy.Copy
     Sheets("النتائج").Cells(m + 1, 1).PasteSpecial
     m = m + 1
     End If
     Next
      Sheets("النتائج").Range("b:b").SortSpecial
      Application.ScreenUpdating = True
      Application.CutCopyMode = False
End Sub

 

[أبو عبد الرحمن سعيد]

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

أخى العزيز الفاضل // الاستاذ سليم

شكرا جزيلا على هذة المشاركة الرائعة

تم إجراء بعض التعديلات على الكود المرسل من سيادتكم  لحتمية وجود الخلايا المدمجة

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

تقبل وافر تقديرى واحترامى

[أبو عبد النور]

السلام عليكم،

بعد إذن الاخ سليم، حل آخر من أجل تعميم الفائدة :

Sub Test()
    With Sheet6
        .Range("A6:I" & .Cells(.Cells.Rows.Count, "A").End(xlUp).Row).Offset(1).ClearContents
    End With
    Range("A6:AB100").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
                                     Sheet6.Range("W1:W2"), CopyToRange:=Sheet6.Range("A6:I6"), Unique:= _
                                     False
End Sub

 

ترحيل البيانات اعتمادا على قيمة نصية.rar