Sub RunMe() Dim x, lRow As Long x = 1 Do lRow = Cells(x, "A").End(xlDown).Row Range(Cells(x, "A"), Cells(lRow, "A")).Copy Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True x = lRow + 2 Loop Until Cells(x, "A").Value = vbNullString Application.CutCopyMode = False End Sub
Sub Convert_to_Rows()
Sheets("Sheet1").Select
Range("A1").Select
Dim x, lRow As Long
x = 1
Do
lRow = Cells(x, "A").End(xlDown).Row
Range(Cells(x, "A"), Cells(lRow, "A")).Copy
Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
x = lRow + 2
Loop Until Cells(x, "A").Value = vbNullString
Application.CutCopyMode = False
'copy to sheet 6
Sheets("Sheet1").Select
Columns("A:A").Select
Selection.Copy
Sheets("Sheet6").Select
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Sheets("Menu").Select
' Delete A from sheet 1
Sheets("Sheet1").Select
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Sheets("Menu").Select
End Sub
Sub Create_Raw_Data()
Sheets("Sheet1").Columns("A:F").Copy Sheets("Raw").Range("A1")
Dim LR As Long
LR = ActiveSheet.UsedRange.Rows.Count + 1
Sheets("Raw").Select
Dim ws As Worksheet
Dim lRow As Long
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Raw")
With ws
'~~> Find last row in Col A
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Enter the formula in one go
.Range("G1:G" & lRow).FormulaR1C1 = "=IFERROR(INDEX(Sheet1!R, MATCH("" Site*"", Sheet1!R, 0)),"""") "
.Range("H1:H" & lRow).FormulaR1C1 = "=IFERROR(INDEX(Sheet1!R, MATCH("" User*"", Sheet1!R, 0)),"""") "
.Range("I1:I" & lRow).FormulaR1C1 = "=IFERROR(INDEX(Sheet1!R, MATCH("" INS*"", Sheet1!R, 0)),"""") "
.Range("J1:J" & lRow).FormulaR1C1 = "=IFERROR(INDEX(Sheet1!R, MATCH("" IEC*"", Sheet1!R, 0)),"""") "
.Range("K1:K" & lRow).FormulaR1C1 = "=IFERROR(INDEX(Sheet1!R, MATCH("" EARTH C*"", Sheet1!R, 0)),"""") "
.Range("L1:L" & lRow).FormulaR1C1 = "=IFERROR(INDEX(Sheet1!R, MATCH("" EARTH *"", Sheet1!R, 0)),"""") "
.Range("M1:M" & lRow).FormulaR1C1 = "=IFERROR(INDEX(Sheet1!R, MATCH("" Lead*"", Sheet1!R, 0)),"""") "
End With
Sheets("Menu").Select
End Sub
Sub Delete_Extra_Data()
'Delete all INS, Earth & Lead then convert to rows
Sheets("Sheet6").Select
With ActiveSheet
.AutoFilterMode = False
With Range("a1", Range("a" & Rows.Count).End(xlUp))
.AutoFilter 1, " INS*"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
.AutoFilterMode = False
End With
With ActiveSheet
.AutoFilterMode = False
With Range("a1", Range("a" & Rows.Count).End(xlUp))
.AutoFilter 1, " LEAD*"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
.AutoFilterMode = False
End With
With ActiveSheet
.AutoFilterMode = False
With Range("a1", Range("a" & Rows.Count).End(xlUp))
.AutoFilter 1, " IEC*"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
.AutoFilterMode = False
End With
With ActiveSheet
.AutoFilterMode = False
With Range("a1", Range("a" & Rows.Count).End(xlUp))
.AutoFilter 1, " EARTH*"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
.AutoFilterMode = False
End With
Sheets("Sheet6").Select
Range("A1").Select
Dim x, lRow As Long
x = 1
Do
lRow = Cells(x, "A").End(xlDown).Row
Range(Cells(x, "A"), Cells(lRow, "A")).Copy
Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
x = lRow + 2
Loop Until Cells(x, "A").Value = vbNullString
Application.CutCopyMode = False
' Delete A from sheet 1
Sheets("Sheet6").Select
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Sheets("Menu").Select
End Sub
Sub Format_Results()
If MsgBox("Are All The States Green, if not the results will not process, please cancel and do the step which is red", vbYesNo + vbQuestion) = vbNo Then
Exit Sub
End If
Dim ws As Worksheet
Dim lRow As Long
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet3")
With ws
'~~> Enter the formula in one go
.Range("A6:A3026").FormulaR1C1 = "=RIGHT(Raw!R[-4]C,LEN(Raw!R[-4]C)-12)"
.Range("B6:B3026").FormulaR1C1 = "=RIGHT(Raw!R[-4]C,LEN(Raw!R[-4]C)-6)"
.Range("C6:C3026").FormulaR1C1 = "=RIGHT(Raw!R[-4]C,LEN(Raw!R[-4]C)-6)"
.Range("D6:D3026").FormulaR1C1 = "=RIGHT(Raw!R[-4]C[1],LEN(Raw!R[-4]C[1])-8)"
.Range("E6:E3026").FormulaR1C1 = "=RIGHT(Raw!R[-4]C[3],LEN(Raw!R[-4]C[3])-6)"
.Range("F6:F3026").FormulaR1C1 = "=IF(ISERROR(RIGHT(Raw!R[-4]C[3],LEN(Raw!R[-4]C[3])-6)),"""",(RIGHT(Raw!R[-4]C[3],LEN(Raw!R[-4]C[3])-6)) )"
.Range("G6:G3026").FormulaR1C1 = "=IF(ISERROR(RIGHT(Raw!R[-4]C[5],LEN(Raw!R[-4]C[5])-6)),"""",(RIGHT(Raw!R[-4]C[5],LEN(Raw!R[-4]C[5])-6)) )"
.Range("H6:H3026").FormulaR1C1 = "=IF(ISERROR(RIGHT(Raw!R[-4]C[2],LEN(Raw!R[-4]C[2])-6)),"""",(RIGHT(Raw!R[-4]C[2],LEN(Raw!R[-4]C[2])-6)) )"
.Range("I6:I3026").FormulaR1C1 = "=IF(ISERROR(RIGHT(Raw!R[-4]C[4],LEN(Raw!R[-4]C[4])-17)),"""",(RIGHT(Raw!R[-4]C[4],LEN(Raw!R[-4]C[4])-17)) )"
.Range("J6:J3026").FormulaR1C1 = "=RIGHT(Sheet6!R[-4]C[1],LEN(Sheet6!R[-4]C[1])-5)"
.Range("K6:K3026").FormulaR1C1 = "=RIGHT(Sheet6!R[-4]C[-1],LEN(Sheet6!R[-4]C[-1])-9)"
.Range("L6:L3026").FormulaR1C1 = "=IF(ISERROR(RIGHT(Sheet6!R[-4]C,LEN(Sheet6!R[-4]C)-6)),"""",(RIGHT(Sheet6!R[-4]C,LEN(Sheet6!R[-4]C)-6)) )"
End With
Sheets("Sheet3").Select
Range("A6:L3026").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Sheets("Sheet3").Select
ActiveSheet.Range("$A$5:$L$3026").AutoFilter Field:=1, Criteria1:="*", Operator:=xlFilterValues
End Sub
Sub RunMe() Dim x, y, lRow As Long x = 1 Do lRow = Cells(x, "A").End(xlDown).Row Range(Cells(x, "A"), Cells(lRow, "A")).Copy Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True x = lRow + 2 Loop Until Cells(x, "A").Value = vbNullString Application.CutCopyMode = False x = 2 Do Until IsEmpty(Cells(x, "H")) If Left(Cells(x, "H"), 3) <> "IEC" Then Range(Cells(x, "H"), Cells(x, "Z")).Cut Cells(x, "I") End If x = x + 1 Loop x = 2 Do Until IsEmpty(Cells(x, "I")) If Left(Cells(x, "I"), 3) <> "INS" Then Range(Cells(x, "I"), Cells(x, "Z")).Cut Cells(x, "J") End If x = x + 1 Loop x = 2 Do Until IsEmpty(Cells(x, "J")) If Left(Cells(x, "J"), 4) <> "LEAD" Then Range(Cells(x, "J"), Cells(x, "Z")).Cut Cells(x, "K") End If x = x + 1 Loop End Sub