Cladcore
02-09-2016, 06:44 AM
15376
This is my data
For every UO1 theres S27 directly below it there can be multiple S27s for 1 UO1
and they allways relate to the Closest UO1 above it
what i need to happen is for every s27 row
the related UO1 row gets duplucated and the s27 moved accross
EXAMPLE:
UO1-01
S27-01
S27-02
U01 -02
S27-01
U01-03
After macro was run it would turn into this
Example
U01-01 S27-01
U01-01 S27-02
U01-02 S27-01
U01-03 S27-01
here is the code i have its close but doesnt work properly
Sub Test_cut()
Application.ScreenUpdating = False
ActiveSheet.Range("A2").Select
'Define the range variables
Dim aCell As Range
Dim bCell As Range
Dim cCell As Range
Dim dCell As Range
Dim eCell As Range
Dim fCell As Range
Dim lrow As Long
' lrow = Cells(Rows.Count, 1).End(xlUp).Row
' MsgBox (lrow)
Dim Trans_count As Long
' Trans_count = Application.WorksheetFunction.CountIf(Range("A:A"), "TRANS")
Trans_count = Cells(Rows.Count, 1).End(xlUp).Row
MsgBox (Trans_count)
'Define the search criteria variables
Dim Trans$
Dim MTPNT$
Dim ADDRS$
Dim ASSET$
Dim METER$
Dim REGST$
'The text for which to search
Trans = "U02"
MTPNT = "S72"
ADDRS = "ADDRS"
ASSET = "ASSET"
METER = "METER"
REGST = "REGST"
'Now cut up the data for the correct number of TRANS records you found earlier
i = 0
Do Until i = Trans_count
i = i + 1
If ActiveCell.Value = "" Then
Call Delete_row
ElseIf ActiveCell.Value = ("U02") Then
Call a_Trans
ElseIf ActiveCell.Value = ("S72") Then
Call a_cut
ElseIf ActiveCell.Value = ("ADDRS") Then
Call B_cut
ElseIf ActiveCell.Value = ("ASSET") Then
Call C_cut
ElseIf ActiveCell.Value = ("METER") Then
Call D_cut
ElseIf ActiveCell.Value = ("REGST") Then
Call E_cut
ElseIf ActiveCell.Value = ("HEADR") Then
Call H_Skip
ElseIf ActiveCell.Value = ("TRAIL") Then
Call T_Skip
End If
Loop
Application.ScreenUpdating = True
MsgBox ("done!")
End Sub
Sub a_Trans()
ActiveCell.Offset(1, 0).Select
End Sub
Sub a_cut()
ActiveCell.Offset(-1, 0).Range(Cells(1, 16), (Cells(1, 30))).Value = ActiveCell.Range(Cells(1, 1), (Cells(1, 15))).Value
ActiveCell.EntireRow.Select
Selection.Delete Shift:=xlUp
End Sub
Sub B_cut()
ActiveCell.Offset(-1, 0).Range(Cells(1, 31), (Cells(1, 45))).Value = ActiveCell.Range(Cells(1, 1), (Cells(1, 15))).Value
ActiveCell.EntireRow.Select
Selection.Delete Shift:=xlUp
End Sub
Sub C_cut()
ActiveCell.Offset(-1, 0).Range(Cells(1, 46), (Cells(1, 60))).Value = ActiveCell.Range(Cells(1, 1), (Cells(1, 15))).Value
ActiveCell.EntireRow.Select
Selection.Delete Shift:=xlUp
End Sub
Sub D_cut()
ActiveCell.Offset(-1, 0).Range(Cells(1, 61), (Cells(1, 75))).Value = ActiveCell.Range(Cells(1, 1), (Cells(1, 15))).Value
ActiveCell.EntireRow.Select
Selection.Delete Shift:=xlUp
End Sub
Sub E_cut()
ActiveCell.Offset(-1, 0).Range(Cells(1, 76), (Cells(1, 90))).Value = ActiveCell.Range(Cells(1, 1), (Cells(1, 15))).Value
ActiveCell.EntireRow.Select
Selection.Delete Shift:=xlUp
End Sub
Sub H_Skip()
ActiveCell.Offset(1, 0).Select
End Sub
Sub T_Skip()
ActiveCell.Offset(1, 0).Select
End Sub
Sub Delete_row()
ActiveCell.EntireRow.Select
Selection.Delete Shift:=xlUp
End Sub
'Sub c_msg()
' MsgBox ("hello Msg")
'End Sub
This is my data
For every UO1 theres S27 directly below it there can be multiple S27s for 1 UO1
and they allways relate to the Closest UO1 above it
what i need to happen is for every s27 row
the related UO1 row gets duplucated and the s27 moved accross
EXAMPLE:
UO1-01
S27-01
S27-02
U01 -02
S27-01
U01-03
After macro was run it would turn into this
Example
U01-01 S27-01
U01-01 S27-02
U01-02 S27-01
U01-03 S27-01
here is the code i have its close but doesnt work properly
Sub Test_cut()
Application.ScreenUpdating = False
ActiveSheet.Range("A2").Select
'Define the range variables
Dim aCell As Range
Dim bCell As Range
Dim cCell As Range
Dim dCell As Range
Dim eCell As Range
Dim fCell As Range
Dim lrow As Long
' lrow = Cells(Rows.Count, 1).End(xlUp).Row
' MsgBox (lrow)
Dim Trans_count As Long
' Trans_count = Application.WorksheetFunction.CountIf(Range("A:A"), "TRANS")
Trans_count = Cells(Rows.Count, 1).End(xlUp).Row
MsgBox (Trans_count)
'Define the search criteria variables
Dim Trans$
Dim MTPNT$
Dim ADDRS$
Dim ASSET$
Dim METER$
Dim REGST$
'The text for which to search
Trans = "U02"
MTPNT = "S72"
ADDRS = "ADDRS"
ASSET = "ASSET"
METER = "METER"
REGST = "REGST"
'Now cut up the data for the correct number of TRANS records you found earlier
i = 0
Do Until i = Trans_count
i = i + 1
If ActiveCell.Value = "" Then
Call Delete_row
ElseIf ActiveCell.Value = ("U02") Then
Call a_Trans
ElseIf ActiveCell.Value = ("S72") Then
Call a_cut
ElseIf ActiveCell.Value = ("ADDRS") Then
Call B_cut
ElseIf ActiveCell.Value = ("ASSET") Then
Call C_cut
ElseIf ActiveCell.Value = ("METER") Then
Call D_cut
ElseIf ActiveCell.Value = ("REGST") Then
Call E_cut
ElseIf ActiveCell.Value = ("HEADR") Then
Call H_Skip
ElseIf ActiveCell.Value = ("TRAIL") Then
Call T_Skip
End If
Loop
Application.ScreenUpdating = True
MsgBox ("done!")
End Sub
Sub a_Trans()
ActiveCell.Offset(1, 0).Select
End Sub
Sub a_cut()
ActiveCell.Offset(-1, 0).Range(Cells(1, 16), (Cells(1, 30))).Value = ActiveCell.Range(Cells(1, 1), (Cells(1, 15))).Value
ActiveCell.EntireRow.Select
Selection.Delete Shift:=xlUp
End Sub
Sub B_cut()
ActiveCell.Offset(-1, 0).Range(Cells(1, 31), (Cells(1, 45))).Value = ActiveCell.Range(Cells(1, 1), (Cells(1, 15))).Value
ActiveCell.EntireRow.Select
Selection.Delete Shift:=xlUp
End Sub
Sub C_cut()
ActiveCell.Offset(-1, 0).Range(Cells(1, 46), (Cells(1, 60))).Value = ActiveCell.Range(Cells(1, 1), (Cells(1, 15))).Value
ActiveCell.EntireRow.Select
Selection.Delete Shift:=xlUp
End Sub
Sub D_cut()
ActiveCell.Offset(-1, 0).Range(Cells(1, 61), (Cells(1, 75))).Value = ActiveCell.Range(Cells(1, 1), (Cells(1, 15))).Value
ActiveCell.EntireRow.Select
Selection.Delete Shift:=xlUp
End Sub
Sub E_cut()
ActiveCell.Offset(-1, 0).Range(Cells(1, 76), (Cells(1, 90))).Value = ActiveCell.Range(Cells(1, 1), (Cells(1, 15))).Value
ActiveCell.EntireRow.Select
Selection.Delete Shift:=xlUp
End Sub
Sub H_Skip()
ActiveCell.Offset(1, 0).Select
End Sub
Sub T_Skip()
ActiveCell.Offset(1, 0).Select
End Sub
Sub Delete_row()
ActiveCell.EntireRow.Select
Selection.Delete Shift:=xlUp
End Sub
'Sub c_msg()
' MsgBox ("hello Msg")
'End Sub