Home Menu

Menu


ExcelBanter » Excel Newsgroups » Excel Discussion (Misc queries) > JLatham MVP (Macro)
Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Posted to microsoft.public.excel.misc
external usenet poster
  
Posts: 3,101
Default JLatham MVP (Macro)
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
Reply With QuoteReply With Quote
  #2   Report Post  
Posted to microsoft.public.excel.misc
external usenet poster
  
Posts: 3,365
Default JLatham MVP (Macro)
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.


"Mike" wrote:

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
Reply With QuoteReply With Quote
  #3   Report Post  
Posted to microsoft.public.excel.misc
external usenet poster
  
Posts: 3,365
Default JLatham MVP (Macro)
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" wrote:

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.


"Mike" wrote:

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
Reply With QuoteReply With Quote
  #4   Report Post  
Posted to microsoft.public.excel.misc
external usenet poster
  
Posts: 3,365
Default JLatham MVP (Macro)
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


"Mike" wrote:

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
Reply With QuoteReply With Quote
Reply
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes
Linear Mode Linear Mode

Posting Rules
Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On

Similar Threads
Thread Thread Starter Forum Replies Last Post
how do I email amacro? leo Excel Worksheet Functions 24 August 9th 06 02:47 PM
error when running cut & paste macro Otto Moehrbach Excel Worksheet Functions 4 August 9th 06 01:49 PM
Search, Copy, Paste Macro in Excel [email protected] Excel Worksheet Functions 0 January 3rd 06 06:51 PM
Closing File Error jcliquidtension Excel Discussion (Misc queries) 4 October 20th 05 12:22 PM
Highlight Range - wrong macro, please edit. Danny Excel Worksheet Functions 8 October 19th 05 11:11 PM


All times are GMT +1. The time now is 10:22 AM.

Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
Copyright ©2004-2025 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"

 

Contact Us ExcelBanter forum home Privacy Statement