السلام عليكم
والله توضيحك غير واضح
حسب مافهمت اطلع على المرفق
وهذا الكود
Sub so()
Application.ScreenUpdating = False
On Error Resume Next
Sheets("Sheet1").Range("a1").Value = "u"
If Sheets("Sheet1").Range("a1").Value = "u" Then
Range("c2:c719").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=LEFT(c2)=LEFT($A$1)"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
[a1].Select
On Error Resume Next
Dim D_ALI As Date
Dim db_ALI As Double
[am1].Value = Now()
If IsDate(Range("am1")) Then
db_ALI = Range("am1")
db_ALI = DateSerial(Year(db_ALI), Month(db_ALI), Day(db_ALI))
Range("a1:m1").AutoFilter
Sheets("sheet1").Range("$A$1:$j$5000").AutoFilter Field:=3, _
Criteria1:=RGB(255, 0, 0), Operator:=xlFilterCellColor
Sheets("sheet1").Range("$A$1:$j$5000").AutoFilter Field:=2, _
Criteria1:="<" & db_ALI
End If
Dim c As Range
With Range("A1:a1")
Set c = .Find("u", , LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
c.Select
row_1 = ActiveCell.Row
[a1].Value = "NAME"
Range("a2" & row_1 & ":c" & row_1).Copy
Sheets("Sheet2").Range("a3").PasteSpecial Paste:=xlPasteAllUsingSourceTheme
Application.CutCopyMode = False
Application.ScreenUpdating = True
Sheets("Sheet2").Select
Columns("a:a").AutoFit
ER = WorksheetFunction.CountA(Range("a:c")) + 1
RN = "A2:m" & ER
Sheets("Sheet2").Range(RN).PrintOut Copies:=1, Preview:=True, Collate:=True
Application.ScreenUpdating = False
Selection.Delete Shift:=xlToLeft
Range("a3:m" & Rows.Count).Clear
Sheets("Sheet1").Select
Sheets("Sheet1").Range("a1").Value = "NAME"
Cells.FormatConditions.Delete
[a1].Select
Application.ScreenUpdating = True
Application.Calculation = xlCalc
Else
Cells.FormatConditions.Delete
[a1].Select
Exit Sub
End If
End With
Sheets("Sheet1").Range("a1:m1").AutoFilter Field:=2
Sheets("Sheet1").Range("a1:m1").AutoFilter Field:=3
End If
End Sub
ان شاء الله يكون هو المطلوب
واي ملاحظات او تعديل انا موجود
TQR_alidroos.rar