JLatham MVP (Macro)

[Mike]

Could You Look over And Maybe Clean up
I have Store Nuber in (B2) And If SOD in I3 is 0 it will move row 2 as well

And MIDC is the Warehouse name

Sub MIDC()
Const SOD = "I3"
Dim EmptyRow As Long
Dim MovedCount As Long
Dim LC As Long


EmptyRow = Range("I" & Rows.Count).End(xlUp).Row + 3
Application.ScreenUpdating = False
Do Until (MovedCount + LC) >= EmptyRow
If Range(SOD).Offset(LC, 0) = 0 Then
Rows(Range(SOD).Offset(LC, 0).Row & _
":" & Range(SOD).Offset(LC, 0).Row).Copy
Rows(EmptyRow & ":" & EmptyRow).Select
ActiveSheet.Paste
Rows(Range(SOD).Offset(LC, 0).Row & ":" & _
Range(SOD).Offset(LC, 0).Row).Delete Shift:=xlUp
MovedCount = MovedCount + 3
LC = LC - 1
Else
LC = LC + 1
End If
Loop
Range(SOD).Select
Application.ScreenUpdating = True
Dim LastRowUsed As Long
Dim TestValue As Long


LastRowUsed = Range("C" & Rows.Count).End(xlUp).Row
TestValue = 19999
Range("C4").Select
Application.ScreenUpdating = False
Do Until TestValue > 99999
If ActiveCell.Offset(-1, 0) <= TestValue And _
ActiveCell.Value > TestValue Then

Selection.EntireRow.Insert
LastRowUsed = LastRowUsed + 1
TestValue = TestValue + 10000
End If
ActiveCell.Offset(1, 0).Activate
If ActiveCell.Row > LastRowUsed Then
Exit Do
End If
Loop

Columns("B:I").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

End Sub

 

[JLatham]

Mike,
would it be possible for you to send a copy of the workbook to me as an
email attachment? I could make sure things are working better that way.

At this point I'm curious as to why you set up MovedCount to increment by 3
within the If...Else statement? It is only moving one row at a time, so in
there it should only increment by 1, not 3. I think I can figure out why you
changed the definition of EmptyRow = statement - that will cause the first
copied zero row to be a couple of rows below the original list.

But if it is working properly now, then don't worry about that. I'm just
not sure from your statement "And If SOD in I3 is 0 it will move row 2 as
well" if that means this is a good thing, or a bad thing?

As for general cleanup - you could move the 'Dim' statements (for
LastRowUsed and TestValue) up under the other Dim statements at the
beginning, just for neatness. You could also move the
Application.ScreenUpdating=True statement that is just after
Range(SOD).Select
down to just before the End Sub statement, and you can delete the
Application.ScreenUpdating=False statement right after the
Range("C4").Select statement, since we've already turned that off earlier.

In theory you shouldn't even actually need the
Application.ScreenUpdating=True
statement to set it back on. It should get turned back on automatically by
Excel when the routine ends at the End Sub statement. But I'm a bit anal
about such things at times, and anything I turned off, I like to turn back on
myself.

 

[JLatham]

If I am right and your comment about moving row 2 when I3 is zero is
happening (and is a bad thing), then I think that this brute force fix will
take care of it. Add this code right below the LC = LC -1 statement:

Do While Range(SOD).Offset(LC,0).Row < Range(SOD).Row
LC = LC+1
Loop

It should actually only get run once during the process, and what it says is
that if the value in LC goes negative, then bump it back up to where it is
zero again so that you're not moving rows up above where SOD is (at I3).

so that part of the code should look like this:

LC= LC - 1
Do While Range(SOD).Offset(LC,0).Row < Range(SOD).Row
LC = LC+1
Loop
Else
LC = LC + 1
End If

 

[JLatham]

Your file received, worked over, conflicts between the move of zero values
and spacing between number ranges resolved, and code added to provide prompt
to Save As. File returned via email attachment.

Happy New Year.

To share with anyone who was following all of this, the 'final' code is:

Sub MIDC()
Const SOD = "I3"
Dim EmptyRow As Long
Dim MovedCount As Long
Dim LC As Long
Dim LastRowUsed As Long
Dim TestValue As Long

EmptyRow = Range("I" & Rows.Count).End(xlUp).Row + 3
Application.ScreenUpdating = False

'adjusted formula to account for extra blank rows and headers
Do Until (MovedCount + LC + Range(SOD).Row + 2) >= EmptyRow
If Range(SOD).Offset(LC, 0) = 0 Then
Rows(Range(SOD).Offset(LC, 0).Row & _
":" & Range(SOD).Offset(LC, 0).Row).Copy
Rows(EmptyRow & ":" & EmptyRow).Select
ActiveSheet.Paste
Rows(Range(SOD).Offset(LC, 0).Row & ":" & _
Range(SOD).Offset(LC, 0).Row).Delete Shift:=xlUp
MovedCount = MovedCount + 1
LC = LC - 1
'next fixes moving rows prior to SOD row.
If LC < 0 Then
LC = 0
End If
Else
LC = LC + 1
End If
Loop

'changed to pick up new area that non-zero received items occupies
LastRowUsed = Range(SOD).Offset(LC, 0).Row
TestValue = 19999
Range("C" & Range(SOD).Row + 1).Select ' synchronize with SOD
Do Until TestValue > 99999
If ActiveCell.Offset(-1, 0) <= TestValue And _
ActiveCell.Value > TestValue Then
Selection.EntireRow.Insert
LastRowUsed = LastRowUsed + 1
TestValue = TestValue + 10000
End If
ActiveCell.Offset(1, 0).Activate
If ActiveCell.Row > LastRowUsed Then
Exit Do
End If
Loop

'added to just pick up and print the rows actually used,
'not all that may have formatting left over from import from QuickBooks
Range("A1:I" & Range("I" & Rows.Count).End(xlUp).Row).Select
ActiveSheet.PageSetup.PrintArea = Selection.Address
'now give what we want borders that we want
Range("B1:I" & Range("I" & Rows.Count).End(xlUp).Row).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Range("B2").Select ' unselect the huge bunch
If Range("B2").Value = "" Then
MsgBox "Unable to rename sheet. Not an error."
PromptForSave
Exit Sub
End If
'prevent potential error
On Error Resume Next
ActiveSheet.Name = Range("B2").Value
If Err <> 0 Then
Err.Clear
End If
PromptForSave
End Sub

Private Sub PromptForSave()
'made Private so it doesn't show up in Macro List
Application.Dialogs(xlDialogSaveAs).Show
End Sub