PDA

View Full Version : Loop within a loop vba



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

SamT
02-09-2016, 11:30 AM
What do you mean "it doesn't work properly"? What does it do or not do?

You have three "Skip" Subs. You only need one.

One problem I see is that in a loop, you must delete rows from the bottom up.

If you loop with For u = Trans_count to 2 step - 1 you can refer to the cell to work with by using Cells(u, 1)

When you find a "U" cell, you can use an other loop to find the last "S" Cell under it

s = 0
Do while Left(Cells(u + s, 1), 1) <> "U"
s =s + 1
LoopThen loop backwards thru them:

For s = s to 0 Step - 1
Cells(u + s, 1)
Next

To skip a Row, use i = i - 1

Work on your code using these tips and get back to us. There are other tips that can make your code more efficient and easier to understand.