Cell Movement

[Ann]

Hi,

I have the following code that someone on this site wrote for me and I love
it and use it all the time. My problem is that this goes down the rows
looking for the city, state and zip code , finds it, selects the row, and
move backwards to select the rows above that I need. Then they are copied,
pasted (transposed) in the next columns over. I still need it to find the
city, state and zip code but select the cell they are in and then move to the
left by one cell, copy those two cells, and now when it pastes in the
adjacent columns I no longer need it to be transposed. I hope that makes
sense and I hope someone can help me.

Dim iRow As Long

For iRow = 1 To 32999

Range("A1").Select

Range("A" & iRow).Select
If Selection Like "*,?? ?????" Then

Range("A" & iRow & ":A" & iRow - 2).Select
Range("A" & iRow & ":A" & iRow - 2).Copy
Range("B" & iRow - 1 & ":B" & iRow - 1).PasteSpecial , , , True

End If
Next

Dim iRow As Long

For iRow = 1 To 160

Range("A1").Select

If iRow = 1 Then
Selection.EntireRow.Insert
End If

Range("A" & iRow).Select
If Selection Like "*,?? ?????" Then

Range("A" & iRow & ":A" & iRow - 2).Select
Range("A" & iRow & ":A" & iRow - 2).Copy
Range("B" & iRow - 1 & ":B" & iRow - 1).PasteSpecial , , , True

End If
Next

 

[Don Guillett]

Seems like a chore to loop thru 33000 cells when FIND will find it
quicker...
If desired, send your file to my address below. I will only look if:
1. You send a copy of this message on an inserted sheet
2. You give me the newsgroup and the subject line
3. You send a clear explanation of what you want
4. You send before/after examples and expected results.

 

[Don Guillett]

Sub fixdatabaseSAS()
Application.ScreenUpdating = False
MoveEmSAS
MoveEm1SAS
cleanupSAS
Application.ScreenUpdating = True
End Sub

Private Sub MoveEmSAS()
Dim i As Long
For i = Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1
If Val(Left(Cells(i, 2), 1)) < 1 Then
Cells(i, 2).Cut
Cells(i - 1, 3).Insert Shift:=xlToRight
End If
Next i
End Sub

Private Sub MoveEm1SAS()
Dim i As Long
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If Cells(i, 2) = "" Then
Cells(i, 1).Cut
Cells(i - 1, 2).Insert Shift:=xlToRight
End If
Next i
End Sub

Private Sub cleanupSAS()
Dim lr As Long
Dim lc As Double
lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Cells(1, Columns.Count).End(xlToLeft).Column
With Cells(1, 1).Resize(lr, lc)
..WrapText = False
..Rows.AutoFit
..Columns.AutoFit
..SpecialCells(xlCellTypeBlanks).Delete
..Interior.ColorIndex = xlNone
End With
End Sub