لون صف طبقا لكلمة فى خليه ..واخفاء تلقائى

[رامز]

مطلوب مساعدة فى الملف..

عايزين لما نكتب كلمة فى التشغيل فى خانة الحالة امام كل اوردر يتم تظليل الصف اللى فيه تفاصيل الاوردر باللون الاخضر الفاتح ...... ولما نكتب كلمة منتهيه يتم اخفاء الصف بالكامل ..ويمكن الرجوع لتفاصيله او اعادة اظهاره .... ولو ينفع انه يتم ترحيل الاوردر النتهى لتاب تانى يبقى تمام بحيث يكون فيه تاب للاوردرات المنتهيه والاوردرات تحت التشغيل وفى الانتظار..ولكم جزيل الشكر

اوردرات عملاء.xlsx

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

جرب هذ الماكرو

Option Explicit

Sub hide_rows()
Dim my_rg As Range
Dim Copy_Rg As Range
Dim find_Rg As Range
Dim St$: St = "انتهى"
Dim R%, Ro%, x%
Application.ScreenUpdating = False
ARCHIVE.Range("b2").CurrentRegion.Offset(1).Clear
Set my_rg = Main.Range("b3").CurrentRegion.Columns(1)
x = my_rg.Rows.Count
Set find_Rg = my_rg.Find(St, after:=my_rg.Cells(x))
 If Not find_Rg Is Nothing Then
   R% = find_Rg.Row: Ro = R
   Main.Range("b" & Ro).EntireRow.Hidden = True
 Do
   If Copy_Rg Is Nothing Then
    Set Copy_Rg = Main.Range("b" & Ro).Resize(, 10)
    Else
    Set Copy_Rg = Union(Copy_Rg, Main.Range("b" & Ro).Resize(, 10))

   End If

   Set find_Rg = my_rg.FindNext(find_Rg)
   Ro% = find_Rg.Row
   Main.Range("b" & Ro).EntireRow.Hidden = True
   If Ro = R Then Exit Do
 Loop
 Copy_Rg.Copy ARCHIVE.Range("b2")
 ARCHIVE.Columns("b:k").AutoFit
 End If
 Application.ScreenUpdating = True

End Sub
'============================================
Sub show_all()
Application.ScreenUpdating = False
Main.Rows.Hidden = False
Application.ScreenUpdating = True
End Sub

الملف مرفق

 

hide_special_rows.xlsm

[رامز]

جزاك الله كل خير ....مطلوب ايضا ترتيب ادراج الاوردر فى ملف الارشيف حسب تاريخ الطلب ..وليس تاريخ الانهاء ان امكن ؟؟؟

وتقولى بجد ازاى اتعلم اكسل زى حضرتك كدا ..نصيحه يعنى

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

المشكلة سهلة جداً  (على فكرة أين الاعجاب)

فقط اضافة سطر واحد على الكود(ما بين علامات +++++++)

'+++++++++++++++++++++++++++++++++++++++++++++++
ARCHIVE.Range("b2").CurrentRegion.Sort key1:=ARCHIVE.Range("h2"), Header:=1
'++++++++++++++++++++++++++++++++++++++++++++++++

ليصبح الكود هكذا

Option Explicit

Sub hide_rows()
Dim my_rg As Range
Dim Copy_Rg As Range
Dim find_Rg As Range
Dim St$: St = "انتهى"
Dim R%, Ro%, x%
Application.ScreenUpdating = False
ARCHIVE.Range("b2").CurrentRegion.Offset(1).Clear
Set my_rg = Main.Range("b3").CurrentRegion.Columns(1)
x = my_rg.Rows.Count
Set find_Rg = my_rg.Find(St, after:=my_rg.Cells(x))
 If Not find_Rg Is Nothing Then
   R% = find_Rg.Row: Ro = R
   Main.Range("b" & Ro).EntireRow.Hidden = True
 Do
   If Copy_Rg Is Nothing Then
    Set Copy_Rg = Main.Range("b" & Ro).Resize(, 10)
    Else
    Set Copy_Rg = Union(Copy_Rg, Main.Range("b" & Ro).Resize(, 10))

   End If

   Set find_Rg = my_rg.FindNext(find_Rg)
   Ro% = find_Rg.Row
   Main.Range("b" & Ro).EntireRow.Hidden = True
   If Ro = R Then Exit Do
 Loop
 Copy_Rg.Copy ARCHIVE.Range("b2")
 ARCHIVE.Columns("b:k").AutoFit
 End If
 '+++++++++++++++++++++++++++++++++++++++++++++++
 ARCHIVE.Range("b2").CurrentRegion.Sort _
 key1:=ARCHIVE.Range("h2"), Header:=1
 '++++++++++++++++++++++++++++++++++++++++++++++++
 Application.ScreenUpdating = True

End Sub
'============================================
Sub show_all()
Application.ScreenUpdating = False
Main.Rows.Hidden = False
Application.ScreenUpdating = True
End Sub

 

Sort_hide_special_rows.xlsm

[رامز]

استاذ سليم ... واجهتنى مشكلة ...

زر الارشيف اللى بيخفى معتش شغال ..

رفعتلك الملف فى المرفقات .. عايز اعرف فين المشكلة 

اوردرات عملاء.xlsm

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

استبدل الرقم1 بالرقم 2 في هذا السطر من الكود

Set my_rg = Main.Range("b3").CurrentRegion.Columns(1)

 

[رامز]

ممكن تشرحلى ايه السبب .. ايه اللى حصل ؟؟؟ الكود زى ما هوا

[رامز]

...نفس المشكلة حصلت معايا مرة تانيه ( زر الاخفاء معتش بيخفى ... رجاء تشرحلى ايه السبب علشان بحتاج الملف ده علطول 

ليه بيقف الماكرو ومش بيشتغل الا لما اغير ال 1 اللى فى current region  الى رقم اكبر وبعدين اعمله تانى 2

2.xlsm

تم تعديل يوليو 15, 2019 بواسطه رامز

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

استبدل الى هذا الماكرو الذي يجد لك كلمة  انتهى  في اي عامود كانت و يقوم باخفاء الصفوف بعدها

Sub hide_rows()
Dim my_rg As Range
Dim Copy_Rg As Range
Dim find_Rg As Range
Dim St$: St = "انتهى"
Dim R%, Ro%, x%, Y%
Dim t As Boolean
show_all
Application.ScreenUpdating = False
ARCHIVE.Range("D2").CurrentRegion.Offset(1).Clear
Set my_rg = Main.Range("D3").CurrentRegion
For Y = 1 To my_rg.Columns.Count
 t = Not (IsError(Application.Match(St, my_rg.Columns(Y), 0)))
    If t Then
      Exit For
     End If
 Next Y
 If Not (t) Then GoTo LEAVE_ME_OUT
  x = my_rg.Rows.Count
Set find_Rg = my_rg.Columns(Y).Find(St, after:=my_rg.Columns(Y).Cells(x))
 If Not find_Rg Is Nothing Then
   R = find_Rg.Row: Ro = R
 Do
   If Copy_Rg Is Nothing Then
    Set Copy_Rg = Main.Range("b" & R).Resize(, 10)
    Else
    Set Copy_Rg = Union(Copy_Rg, Main.Range("b" & R).Resize(, 10))

   End If

   Set find_Rg = my_rg.FindNext(find_Rg)
   R = find_Rg.Row
   If Ro = R Then Exit Do
 Loop
 Copy_Rg.Copy ARCHIVE.Range("b2")
 Copy_Rg.EntireRow.Hidden = True
 ARCHIVE.Columns("b:k").AutoFit
 End If
 '+++++++++++++++++++++++++++++++++++++++++++++++
 ARCHIVE.Range("b2").CurrentRegion.Sort _
 key1:=ARCHIVE.Range("h2"), Header:=1
 '++++++++++++++++++++++++++++++++++++++++++++++++
LEAVE_ME_OUT:
Set my_rg = Nothing: Set find_Rg = Nothing
Set Copy_Rg = Nothing
 Application.ScreenUpdating = True

End Sub
'============================================
Sub show_all()
Application.ScreenUpdating = False
Main.Rows.Hidden = False
Application.ScreenUpdating = True
End Sub

الملف مرفق

 

 

SAlim_2.xlsm