با سلام
این کد کارهای مورد نیاز شما را انجام میده....
فقط به دلیل حذف ستون یک بار از کد ها در شیت استفاده کنید.
کد:
Sub test()
Dim i, lr As Integer
lr = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
Columns("B:B").Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("b2:E283")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Columns("E:E").Select
Selection.Insert Shift:=xlToRight
For i = 1 To lr
If Range("d" & i).Font.ColorIndex = 3 Then
Range("d" & i).Offset(, 1) = Range("d" & i)
Range("d" & i).Font.ColorIndex = 0
Range("d" & i).Offset(, 1).Font.ColorIndex = 3
Range("d" & i) = ""
End If
Next
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
Columns("B:B").ColumnWidth = 13
Application.ScreenUpdating = True
Range("a1").Select
End Sub
علاقه مندی ها (Bookmarks)