PDA

View Full Version : Formatting strings in cells



twckfa16
02-13-2013, 11:59 AM
Hello,
I'm trying to figure out a way to do the following task:
- Loop through certain cells n Column A.
- IF the format of these cells looks like the below, process as normal.

1)ITEM STOPPAGE - ITEM NAME =PXBBB00457_A
2)LONG MEASURE SIGNAL - ITEM NAME =PXCCC00458_A

If the format is anything different, pick out the keywords and format
as shown above, then process as normal.

Below is a sample of the project I am working on. The way it works now, if the format is correct, as in above, the macros work perfectly. If the cell is not in this format, it fails. So I want to figure out a way to run the macros if the cells ARE in and AREN'T in the crrect format, and get the same result.

*Note - the Before and After tabs are there just to demonstrate what its supposed to look like.
*Note - The grab_type_and_data sub im thinking is where an adjustment should be made

Any help is appreciated.



Sub main()
Call select_all
Call delete_merged
Call copy_num
Call transfer_num
Call delete_req
Call delete_unnecessary
Call grab_type_and_data
Call transfer_num_back
Call final_sort
End Sub

Sub select_all()
Columns("A:A").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
ActiveSheet.Hyperlinks.Delete
End Sub

Sub delete_merged()
Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select

With Selection
.MergeCells = False
End With
End Sub

Sub copy_num()
'Dim lngRow As Long: lngRow = 1
Dim lngLoop As Long: lngLoop = 1
Do Until IsEmpty(Cells(lngLoop, 1))
Cells(lngLoop, 1).Cut Cells(lngRow, "J")
lngLoop = lngLoop + 4
lngRow = lngRow + 1
Loop
End Sub

Sub transfer_num()
Columns("J:J").Select
Selection.Cut
Sheets("Sheet2").Select
Range("J1").Select
ActiveSheet.Paste
Sheets("Sheet1").Select
End Sub

Sub delete_req()
Dim lngLoop As Long: lngLoop = 2
Do Until IsEmpty(Cells(lngLoop, 1))
Cells(lngLoop, 1).ClearContents
lngLoop = lngLoop + 4
Loop
End Sub

Sub delete_unnecessary()
Columns("B:B").Select
Selection.ClearContents
Columns("D:D").Select
Selection.ClearContents
Columns("E:E").Select
Selection.ClearContents
Columns("F:F").Select
Selection.ClearContents
End Sub

Sub grab_type_and_data()
Dim Rng As Range
Dim cel As Range
Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
Application.ScreenUpdating = False
For Each cel In Rng
If cel.Value <> "" Then
cel = Replace(cel, "= P", "=P")
cel.Offset(-2, 0).Value = Split(cel.Value, "=")(1)
cel.Offset(-2, 3).Value = Split(cel.Value, "-")(0)
cel.Offset(-2, 1).Value = Split(cel.Offset(-2, 2).Value, " ")(0)
cel.Offset(-2, 2).Value = Format(Replace(cel.Offset(-2, 2), cel.Offset(-2, 1), " "), "h:mm:ss")
End If
Next cel
With ActiveSheet
.Columns("D:D").AutoFilter Field:=1, Criteria1:="="
.AutoFilter.Range.Offset(1, 0).EntireRow.Delete
.AutoFilterMode = False
.Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub

Sub transfer_num_back()
Sheets("Sheet2").Select
Columns("J:J").Select
Selection.Cut
Sheets("Sheet1").Select
Range("J1").Select
ActiveSheet.Paste
End Sub

Sub final_sort()
Columns("A:J").Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B1:B51") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("C1:C51") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:J51")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub


Thanks,

Mark

Kenneth Hobs
02-13-2013, 12:11 PM
There was no file attachment.

twckfa16
02-13-2013, 12:14 PM
Here you go:


Thanks,