Inserting 2 columns when cells don't match
 

I've created this routing which works but I was hoping for something a
little more clean

Range("D2").Select
Do Until ActiveCell.Offset(0, 1) = ""
If ActiveCell.Offset(0, 1) < ActiveCell Then
Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(0,
2)).EntireColumn.Insert shift:=xlToRight
ActiveCell.Offset(0, 3).Select
Else
ActiveCell.Offset(0, 1).Select
End If
Loop

I had tried the following but it's not working

For Each cell In Range(("D2"), Range("D2").End(xlToRight))
If cell.Offset(0, 1) < cell And cell.Offset(0, 1) < "" Then
Range(cell.Offset(0, 1), cell.Offset(0,
2)).EntireColumn.Insert 'shift:=xlToRight
cell.Offset(0, 3).Select
Else
End If
Next

Inserting 2 columns when cells don't match
 

I find it much easier to work with the column numbers and looping from the
rightmost toward the left in cases like this (and starting at the bottom and
working toward the top when working with rows).

Option Explicit
Sub testme()

Dim iCol As Long
Dim FirstCol As Long
Dim LastCol As Long
Dim wks As Worksheet

Set wks = Worksheets("sheet1") 'ActiveSheet ???

With wks
FirstCol = .Range("D2").Column '4
LastCol = .Range("D2").End(xlToRight).Column

For iCol = LastCol To FirstCol + 1 Step -1
If .Cells(2, iCol).Value < .Cells(2, iCol - 1).Value Then
.Cells(2, iCol).Resize(, 2).EntireColumn.Insert
End If
Next iCol
End With

End Sub



On 11/12/2010 12:29, Frank wrote:
I've created this routing which works but I was hoping for something a
little more clean

Range("D2").Select
Do Until ActiveCell.Offset(0, 1) = ""
If ActiveCell.Offset(0, 1)< ActiveCell Then
Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(0,
2)).EntireColumn.Insert shift:=xlToRight
ActiveCell.Offset(0, 3).Select
Else
ActiveCell.Offset(0, 1).Select
End If
Loop

I had tried the following but it's not working

For Each cell In Range(("D2"), Range("D2").End(xlToRight))
If cell.Offset(0, 1)< cell And cell.Offset(0, 1)< "" Then
Range(cell.Offset(0, 1), cell.Offset(0,
2)).EntireColumn.Insert 'shift:=xlToRight
cell.Offset(0, 3).Select
Else
End If
Next

--
Dave Peterson

Inserting 2 columns when cells don't match
 

On Nov 12, 12:29*pm, Frank wrote:
I've created this routing which works but I was hoping for something a
little more clean

Range("D2").Select
Do Until ActiveCell.Offset(0, 1) = ""
* * If ActiveCell.Offset(0, 1) < ActiveCell Then
* * * * Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(0,
2)).EntireColumn.Insert shift:=xlToRight
* * * * ActiveCell.Offset(0, 3).Select
* * * * Else
* * * * ActiveCell.Offset(0, 1).Select
* * End If
Loop

I had tried the following but it's not working

For Each cell In Range(("D2"), Range("D2").End(xlToRight))
* * If cell.Offset(0, 1) < cell And cell.Offset(0, 1) < "" Then
* * * * Range(cell.Offset(0, 1), cell.Offset(0,
2)).EntireColumn.Insert 'shift:=xlToRight
* * * * cell.Offset(0, 3).Select
* * * * Else
* * End If
Next

Something simple like this?
Sub insertcolsifnomatch()
Dim i As Long
For i = Cells(2, Columns.Count).End(xlToLeft).Column To 4 Step -2
If Cells(2, i - 1) < Cells(2, i) Then Columns(i).Resize(, 2).Insert
Next i
End Sub

Inserting 2 columns when cells don't match
 

If the contents of D2 to the end of the row are constants (that is, they NOT
the result of formulas), then you could consider using this non-looping
code...

With Range("D2", Cells(2, Columns.Count).End(xlToLeft))
.Replace .Cells(1), "=" & .Cells(1), xlWhole
.SpecialCells(xlCellTypeConstants).Offset(0, 1).Insert xlShiftToRight
.SpecialCells(xlCellTypeConstants).Offset(0, 1).Insert xlShiftToRight
.SpecialCells(xlCellTypeFormulas).Replace "=", "", xlPart
End With

--
Rick Rothstein (MVP - Excel)



"Frank" wrote in message
...
I've created this routing which works but I was hoping for something a
little more clean

Range("D2").Select
Do Until ActiveCell.Offset(0, 1) = ""
If ActiveCell.Offset(0, 1) < ActiveCell Then
Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(0,
2)).EntireColumn.Insert shift:=xlToRight
ActiveCell.Offset(0, 3).Select
Else
ActiveCell.Offset(0, 1).Select
End If
Loop

I had tried the following but it's not working

For Each cell In Range(("D2"), Range("D2").End(xlToRight))
If cell.Offset(0, 1) < cell And cell.Offset(0, 1) < "" Then
Range(cell.Offset(0, 1), cell.Offset(0,
2)).EntireColumn.Insert 'shift:=xlToRight
cell.Offset(0, 3).Select
Else
End If
Next

Inserting 2 columns when cells don't match
 

Thanks you to all who responded.

To Don Guillett: Your solution works only every two steps, that is it
only insert two new columns every other time instead of every time.

To Dave Peterson: You are always the man and your solution works
perfectly. I wish I could understand your code.

Regards,

Inserting 2 columns when cells don't match
 

If the contents of D2 to the end of the row are constants (that is, they NOT
the result of formulas), then you could consider using this non-looping
code...

With Range("D2", Cells(2, Columns.Count).End(xlToLeft))
.Replace .Cells(1), "=" & .Cells(1), xlWhole
.SpecialCells(xlCellTypeConstants).Offset(0, 1).Insert xlShiftToRight
.SpecialCells(xlCellTypeConstants).Offset(0, 1).Insert xlShiftToRight
.SpecialCells(xlCellTypeFormulas).Replace "=", "", xlPart
End With

--
Rick Rothstein (MVP - Excel)


"Frank" wrote in message
...
I've created this routing which works but I was hoping for something a
little more clean

Range("D2").Select
Do Until ActiveCell.Offset(0, 1) = ""
If ActiveCell.Offset(0, 1) < ActiveCell Then
Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(0,
2)).EntireColumn.Insert shift:=xlToRight
ActiveCell.Offset(0, 3).Select
Else
ActiveCell.Offset(0, 1).Select
End If
Loop

I had tried the following but it's not working

For Each cell In Range(("D2"), Range("D2").End(xlToRight))
If cell.Offset(0, 1) < cell And cell.Offset(0, 1) < "" Then
Range(cell.Offset(0, 1), cell.Offset(0,
2)).EntireColumn.Insert 'shift:=xlToRight
cell.Offset(0, 3).Select
Else
End If
Next

Inserting 2 columns when cells don't match
 

It's not too complex <bg.

I'll add some comments.

Option Explicit
Sub testme()

'some variables.
'column variables for first column, last column and looping column
Dim iCol As Long
Dim FirstCol As Long
Dim LastCol As Long

'just to make it easier to change the worksheet name if you want.
Dim wks As Worksheet

Set wks = Worksheets("sheet1") 'ActiveSheet ???

With wks
'the first, er, leftmost, column starts in column D (column 4)
FirstCol = .Range("D2").Column '4

'the rightmost column is determined the same way you did.
'select D2 and hit End and then right arrow
'then use that cell's column number
LastCol = .Range("D2").End(xlToRight).Column


'start at the righthand column and go towards the lefthand column
'but stop looking at column E.
'Since the code looks to the column to the left of the "looping" column
'and the column to the left of column E is column D -- where you were
'stopping
For iCol = LastCol To FirstCol + 1 Step -1
'if the value in the looping column is different from the value
'directly to its left (icol compared with icol-1), then
'do the work of inserting two columns
If .Cells(2, iCol).Value < .Cells(2, iCol - 1).Value Then
.Cells(2, iCol).Resize(, 2).EntireColumn.Insert
End If
Next iCol
End With

End Sub

On 11/13/2010 11:51, Frank wrote:
Thanks you to all who responded.

To Don Guillett: Your solution works only every two steps, that is it
only insert two new columns every other time instead of every time.

To Dave Peterson: You are always the man and your solution works
perfectly. I wish I could understand your code.

Regards,

--
Dave Peterson