Can you save me hours of work??

zookeepertx

zookeepertx

Well-known Member
Joined
May 27, 2011
Messages
589
Office Version
  1. 365
Platform
  1. Windows
I’m working with Excel 2003 (I know, I know. But it’s my work computer, so I’m stuck with it). I’m hoping to save myself several hours of mind-numbing work a couple of times a month, setting up a spreadsheet. Let me mention that I do not “speak” technical-speak; I can generally get done what I want to do, but I have a lot of trouble expressing it (or comprehending it) verbally, so please, bear with me.
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /><o:p></o:p>
What I have is a spreadsheet that’s 40 columns wide; the first 20 columns are last month’s data (LM) and the next 20 are this month’s data (TM). The number of rows varies every month – anywhere up to 1,100-1,200 rows. The first 3 columns on each side consist of a File #, File Age and Vendor/Company/Department. I have to go through & compare the 2 sides, row by row, looking at the File # and Ven/Co/Dpt. I did Text-To-Columns on the Ven/Co/Dept column to separate out the parts. So, first I need to compare the File # from LM to TM. If they match, then I compare the Ven #s. If those also match, then I compare the Dept #s. (The Co portion is actually irrelevant, by itself). If all 3 columns match exactly, then it’s all good. If either side has a row that the other side doesn’t have, I have to insert a row in all 20 columns of the other side – basically a “place-holder”. The inserted row will only contain the File # and Ven/Co/Dept, but no other data.
<o:p></o:p>
When done, both sides of the spreadsheet contain the same number of rows. When a row is inserted, it doesn’t HAVE to get the File-Ven/Co/Dept plugged in, since I’ll have to go back & format things further, anyway. However, I would be in heaven if I didn’t have to go blind spending several hours shoring up all those rows.
<o:p></o:p>
Has anybody got any ideas for a macro or something that would help me? One possible problem I thought of is that, once a row has been inserted, moving that side of the data down a row, that’s going to throw off a formula, isn’t it? Unless there’s some way to make the solution look at only 1 row at a time, not moving on until each adjustment has been made.
<o:p></o:p>
I know I’ve probably been very confusing, but if I could figure out how to post either a portion of the spreadsheet or a screenshot of it, it’d probably make more sense.
<o:p></o:p>
Anyway, I appreciate any help I can get! A co-worker & I have been tossing this around for several months & haven’t come up with a workable solution. Maybe one of you can save me!
 
Sort by date Sort by votes
Hi,

I'm using Excel 2003, both home & work.

I called my workbook that I made here "Test LM-TM". In VBE, within that name, there are 2 folders - Objects and Modules. Under Objects there are Sheet 1, Sheet 2, Sheet 3 and This Workbook. I originally guessed that I should create a new Module, & pasted the code into that. So, that was wrong?
After reading your reply I tried double clicking on This Workbook under Objects, pasted the code into it & tried running it again, but got the same result as before.
Obviously, I'm doing something wrong.

Oh, I see about the row 8 part now. The data will always start on row 8, so that's no problem.

As far as the worksheet name - the workBOOK name is incremented each month (04-11 LM-TM, 05-11 LM-TM), but the particular workSHEET has the same name all the time (ALL). So, I'll fix that part.

(You didn't really believe me when I said I don't speak technical speak did you? LOLOL! ;) )
 
Upvote 0

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.
LOL. you can speak technically :P or at least sound very much like it haha.

Umm.. I'm sure the problem arises from using excel 2003.
I've just been introduced to VBA (my main area of study is C, C++ and python) so I've been using 2007 from the very start.

So, maybe XL 2003 doesn't have the same VBA code when sorting. So, there are two options which I could do,
1) I make my own sorting algorithms which would probably take more long time to run and develop
2) You record a macro in sorting the range by column C, column B, then column A.

Preferably for the efficiency of the code and the development time of the code, I would strongly recommend the second step.
So, here are the steps: (lol at me for forcefully piling this on you)
A) Record macro
B) Add a new worksheet
C) Copy all of your first set of data to the new worksheet at A1
D) Select all the data in the new worksheet
E) Select sort menu
F) Sort by C; add a key; Sort by B; add a key; Sort by A
G) Stop recording
H) Copy + Paste onto this forum or you can edit it and use it.

So, after the sort it should look like
Code: 
BEFORE:
a    c    d
b    d    g
a    b    c
 
AFTER:
a    b    c
a    c    d
b    d    g
 
Upvote 0
(lol at me for forcefully piling this on you)
Click to expand...

LOL! Forcing me to learn more! How DARE you? LOL!!

Okay, I recorded the macro as well as I could. I don't know how to copy JUST the data to paste on the temp WS, when the data length varies every month, so I just had to paste the whole columns (A-Q) & then hide rows 1-7 to do the sort. I don't remember if I mentioned that column B is for the age of the file, which is irrelevant for this process, but does still need to stay. Column C is a combination of the Vendor #, the Company code (which is also irrelevant right now) and the Department #; these are separated by /. So, when I recorded the macro I inserted 2 columns after C & did a Text to Columns, leaving out the Company code & letting the Vend & Dept #s fall into the new, blank columns D & E. That means the sort is on E, D & A. (Column C needs to be in its original format when all is said & done.)

I tried to go into the macro in VBE & clean it up a little, but that made it not work, so I left it alone. It already took me 8 tries to get THIS far, so I figured I'd better take what I could get to work, LOL!

Code: 
Sub Macro8()
'
' Macro8 Macro
' Macro recorded 5/30/2011 by Jenny Drumm
'
'
    Sheets.Add
    Sheets("ALL").Select
    Columns("A:Q").Select
    Selection.Copy
    Sheets("Sheet11").Select
    Columns("A:A").Select
    ActiveSheet.Paste
    Columns("D:D").Select
    Application.CutCopyMode = False
    Selection.Insert Shift:=xlToRight
    Selection.Insert Shift:=xlToRight
    Rows("1:7").Select
    Selection.EntireRow.Hidden = True
    Columns("C:C").Select
    Range("C8").Activate
    Selection.TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="/", FieldInfo:=Array(Array(1, 1), Array(2, 9), Array(3, 1)), _
        TrailingMinusNumbers:=True
    Cells.Select
    Range("A8").Activate
    Selection.Sort Key1:=Range("E1"), Order1:=xlAscending, Key2:=Range("D1") _
        , Order2:=xlAscending, Key3:=Range("A1"), Order3:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
        xlSortNormal
End Sub
 
Upvote 0
Awesome. Well, I hope this works!

Code: 
Sub kpark91May302011()
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    Dim newWS1 As Worksheet, newWS2 As Worksheet, LR1 As Double, LR2 As Double, dataWS As String
    Dim dataStartRow As Double, balWS As Worksheet
    
    dataStartRow = 8 'Data starting row
    
    dataWS = InputBox("What is your data worksheet's name? (Case-sensitive)")
    On Error GoTo 0
    Set newWS1 = Worksheets.Add(, Sheets(Sheets.count))
    Set newWS2 = Worksheets.Add(, Sheets(Sheets.count)) 'Add Worksheet At the end of the workbook temporarily
    
    LR1 = Worksheets(dataWS).Range("A" & Rows.count).End(xlUp).Row
    LR2 = Worksheets(dataWS).Range("R" & Rows.count).End(xlUp).Row 'Find row # before the first occurrence of a blank cell in the column
    
    'Copy the data into two separate files
    With Worksheets(dataWS)
        .Range("A" & dataStartRow & ":Q" & LR1).Copy newWS1.Cells(1, 1) 'Copy + Paste PM's data into first temp sheet
        .Range("R" & dataStartRow & ":AH" & LR2).Copy newWS2.Cells(1, 1) 'Copy + Paste TM's data into second temp sheet
    End With
    
    'Sort colC, colB, then colA of newWS1
    newWS1.Select
    Selection.Sort Key1:=Range("E1"), Order1:=xlAscending, Key2:=Range("D1") _
    , Order2:=xlAscending, Key3:=Range("A1"), Order3:=xlAscending, Header:= _
    xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
    xlSortNormal
    
    newWS2.Select
    Selection.Sort Key1:=Range("E1"), Order1:=xlAscending, Key2:=Range("D1") _
    , Order2:=xlAscending, Key3:=Range("A1"), Order3:=xlAscending, Header:= _
    xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
    xlSortNormal
    
    'Loop through both new temporary worksheets at the same time
    'Since they are sorted from A to Z, whatever has the bigger value in the same row number as the other worksheet,
    'there will be a new line added above it with the values from the smaller values copied as requested
    'however, if there is comparison between a blank cell and  0, it will be considered as equal, which may cause some problems
    
    Dim nRow As Double
    nRow = 1 'Data starts from row 1 of temporary files
    
    '''Balancing based on three criteria
    Do While Not IsEmpty(newWS1.Cells(nRow, 1).Value) Or Not IsEmpty(newWS2.Cells(nRow, 1).Value)
        If newWS1.Cells(nRow, 1).Value > newWS2.Cells(nRow, 1).Value And newWS2.Cells(nRow, 1).Value <> "" Then
            If newWS2.Cells(nRow, 1).Value <> "" Then
                newWS1.Cells(nRow, 1).EntireRow.Insert
                newWS1.Cells(nRow, 1).Value = newWS2.Cells(nRow, 1).Value
                newWS1.Cells(nRow, 2).Value = newWS2.Cells(nRow, 2).Value
                newWS1.Cells(nRow, 3).Value = newWS2.Cells(nRow, 3).Value
            Else
                newWS2.Cells(nRow, 1).Value = newWS1.Cells(nRow, 1).Value
                newWS2.Cells(nRow, 2).Value = newWS1.Cells(nRow, 2).Value
                newWS2.Cells(nRow, 3).Value = newWS1.Cells(nRow, 3).Value
            End If
        ElseIf newWS1.Cells(nRow, 1).Value < newWS2.Cells(nRow, 1).Value Then
            If newWS1.Cells(nRow, 1).Value <> "" Then
                newWS2.Cells(nRow, 1).EntireRow.Insert
                newWS2.Cells(nRow, 1).Value = newWS1.Cells(nRow, 1).Value
                newWS2.Cells(nRow, 2).Value = newWS1.Cells(nRow, 2).Value
                newWS2.Cells(nRow, 3).Value = newWS1.Cells(nRow, 3).Value
            Else
                newWS1.Cells(nRow, 1).Value = newWS2.Cells(nRow, 1).Value
                newWS1.Cells(nRow, 2).Value = newWS2.Cells(nRow, 2).Value
                newWS1.Cells(nRow, 3).Value = newWS2.Cells(nRow, 3).Value
            End If
        Else
            If newWS1.Cells(nRow, 2).Value > newWS2.Cells(nRow, 2).Value And newWS2.Cells(nRow, 2).Value <> "" Then
                If newWS2.Cells(nRow, 2).Value <> "" Then
                    newWS1.Cells(nRow, 2).EntireRow.Insert
                    newWS1.Cells(nRow, 1).Value = newWS2.Cells(nRow, 1).Value
                    newWS1.Cells(nRow, 2).Value = newWS2.Cells(nRow, 2).Value
                    newWS1.Cells(nRow, 3).Value = newWS2.Cells(nRow, 3).Value
                Else
                    newWS2.Cells(nRow, 1).Value = newWS1.Cells(nRow, 1).Value
                    newWS2.Cells(nRow, 2).Value = newWS1.Cells(nRow, 2).Value
                    newWS2.Cells(nRow, 3).Value = newWS1.Cells(nRow, 3).Value
                End If
            ElseIf newWS1.Cells(nRow, 2).Value < newWS2.Cells(nRow, 2).Value Then
                If newWS1.Cells(nRow, 2).Value <> "" Then
                    newWS2.Cells(nRow, 2).EntireRow.Insert
                    newWS2.Cells(nRow, 1).Value = newWS1.Cells(nRow, 1).Value
                    newWS2.Cells(nRow, 2).Value = newWS1.Cells(nRow, 2).Value
                    newWS2.Cells(nRow, 3).Value = newWS1.Cells(nRow, 3).Value
                Else
                    newWS1.Cells(nRow, 1).Value = newWS2.Cells(nRow, 1).Value
                    newWS1.Cells(nRow, 2).Value = newWS2.Cells(nRow, 2).Value
                    newWS1.Cells(nRow, 3).Value = newWS2.Cells(nRow, 3).Value
                End If
            Else
                If newWS1.Cells(nRow, 3).Value > newWS2.Cells(nRow, 3).Value Then
                    If newWS2.Cells(nRow, 3).Value <> "" Then
                        newWS1.Cells(nRow, 3).EntireRow.Insert
                        newWS1.Cells(nRow, 1).Value = newWS2.Cells(nRow, 1).Value
                        newWS1.Cells(nRow, 2).Value = newWS2.Cells(nRow, 2).Value
                        newWS1.Cells(nRow, 3).Value = newWS2.Cells(nRow, 3).Value
                    Else
                        newWS2.Cells(nRow, 1).Value = newWS1.Cells(nRow, 1).Value
                        newWS2.Cells(nRow, 2).Value = newWS1.Cells(nRow, 2).Value
                        newWS2.Cells(nRow, 3).Value = newWS1.Cells(nRow, 3).Value
                    End If
                ElseIf newWS1.Cells(nRow, 3).Value < newWS2.Cells(nRow, 3).Value Then
                    If newWS1.Cells(nRow, 3).Value <> "" Then
                        newWS2.Cells(nRow, 3).EntireRow.Insert
                        newWS2.Cells(nRow, 1).Value = newWS1.Cells(nRow, 1).Value
                        newWS2.Cells(nRow, 2).Value = newWS1.Cells(nRow, 2).Value
                        newWS2.Cells(nRow, 3).Value = newWS1.Cells(nRow, 3).Value
                    Else
                        newWS1.Cells(nRow, 1).Value = newWS2.Cells(nRow, 1).Value
                        newWS1.Cells(nRow, 2).Value = newWS2.Cells(nRow, 2).Value
                        newWS1.Cells(nRow, 3).Value = newWS2.Cells(nRow, 3).Value
                    End If
                End If
            End If
        End If
        nRow = nRow + 1
    Loop
    
    
    Set balWS = Worksheets.Add(, Sheets(Sheets.count)) 'Create a worksheet that is balanced
    
    'Copy onto new dataworksheet
    Worksheets(dataWS).Range("A1:AH7").Copy balWS.Range("A1")
    newWS1.Range("A1:Q" & nRow).Copy balWS.Range("A8")
    newWS2.Range("A1:Q" & nRow).Copy balWS.Range("R8")
    
    'Delete temporary worksheets
    newWS1.Delete
    newWS2.Delete
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
    End With
End Sub
 
Upvote 0
Solution
OMG! It works, it WORKS!! I'm doing a happy dance over here!! :rofl: (can't find a "happy dance" smilie, so that'll have to do!)

I'll bet you thought I disappeared, didn't you? Once I got in to work, I got buried under month-end processes and at home, I suddenly realized that I hadn't created the newsletter for my riding club yet! So, I had to get on that so, I didn't get to really play with the macro until today. It's amazing! I can't believe you created something so complex! I've been tweaking it a little bit as I realized how it was functioning. Once the temporary sheets are created, it only needs to sort by File, Vendor & Dept; the age column (B) doesn't matter, nor does the Co portion of column C. The Ven/Co/Dept is formatted together (1031/ABC/34 for example), so I'm having each temp WS insert 2 columns after A, then get the vendor # from (what is now) column E & put it in B and the Dept # from E & put it in C. Then have it sort on A, B, C. (When it was sorting on Dep then Vend then File, it was creating a lot of duplicate rows).

Also, when a new row is inserted, I only need it to fill in the File # and the consolidated Ven/Co/Dept, so I changed it to fill the cells in A and E. The final WS had the headings over the wrong columns, but it finally dawned on me that when I inserted 2 columns after A, I offset everything by 2 columns, so I figured out to have those columns get deleted before combining the balanced temp sheets in 1 balanced sheet, since I don't need those columns any more.

You are SO AWESOME!!

One last thing - As long as you're performing miracles, when the temporary worksheets are being compared & a new line is inserted, can that new line be colored a whole different color than the rest? The whole worksheet is color-coded & that would help them to stand out from the others, so I'd know which ones I have to work with.

Thank you. THANK YOU! I'm so excited to show this to somebody; I have to go find someone to come watch this work!

Here's how the coding looks at this point:
Code: 
Sub kpark91May302011()
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    Dim newWS1 As Worksheet, newWS2 As Worksheet, LR1 As Double, LR2 As Double, dataWS As String
    Dim dataStartRow As Double, balWS As Worksheet
 
    dataStartRow = 8 'Data starting row
 
    dataWS = "ALL"
    On Error GoTo 0
    Set newWS1 = Worksheets.Add(, Sheets(Sheets.Count))
    Set newWS2 = Worksheets.Add(, Sheets(Sheets.Count)) 'Add Worksheet At the end of the workbook temporarily
 
    LR1 = Worksheets(dataWS).Range("A" & Rows.Count).End(xlUp).Row
    LR2 = Worksheets(dataWS).Range("R" & Rows.Count).End(xlUp).Row 'Find row # before the first occurrence of a blank cell in the column
 
    'Copy the data into two separate files
    With Worksheets(dataWS)
        .Range("A" & dataStartRow & ":Q" & LR1).Copy newWS1.Cells(1, 1) 'Copy + Paste PM's data into first temp sheet
        .Range("R" & dataStartRow & ":AH" & LR2).Copy newWS2.Cells(1, 1) 'Copy + Paste TM's data into second temp sheet
    End With
 
    'Sort colE, colD, then colA of newWS1
    newWS1.Select
    Columns("B:C").Select
    Range("B1").Activate
    Selection.Insert Shift:=xlToRight
    Columns("E:E").Select
    Range("E1").Activate
    Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="/", FieldInfo:=Array(Array(1, 1), Array(2, 9), Array(3, 1)), _
        TrailingMinusNumbers:=True
 
    newWS2.Select
    Columns("B:C").Select
    Range("B1").Activate
    Selection.Insert Shift:=xlToRight
    Columns("E:E").Select
    Range("E1").Activate
    Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="/", FieldInfo:=Array(Array(1, 1), Array(2, 9), Array(3, 1)), _
        TrailingMinusNumbers:=True
 
    newWS1.Select
    Cells.Select
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("B1") _
    , Order2:=xlAscending, Key3:=Range("C1"), Order3:=xlAscending, Header:= _
    xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
    xlSortNormal
 
    newWS2.Select
    Cells.Select
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("B1") _
    , Order2:=xlAscending, Key3:=Range("C1"), Order3:=xlAscending, Header:= _
    xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
    xlSortNormal
 
    'Loop through both new temporary worksheets at the same time
    'Since they are sorted from A to Z, whatever has the bigger value in the same row number as the other worksheet,
    'there will be a new line added above it with the values from the smaller values copied as requested
    'however, if there is comparison between a blank cell and  0, it will be considered as equal, which may cause some problems
 
    Dim nRow As Double
    nRow = 1 'Data starts from row 1 of temporary files
 
    '''Balancing based on three criteria
    Do While Not IsEmpty(newWS1.Cells(nRow, 1).Value) Or Not IsEmpty(newWS2.Cells(nRow, 1).Value)
        If newWS1.Cells(nRow, 1).Value > newWS2.Cells(nRow, 1).Value And newWS2.Cells(nRow, 1).Value <> "" Then
            If newWS2.Cells(nRow, 1).Value <> "" Then
                newWS1.Cells(nRow, 1).EntireRow.Insert
                newWS1.Cells(nRow, 1).Value = newWS2.Cells(nRow, 1).Value
                newWS1.Cells(nRow, 5).Value = newWS2.Cells(nRow, 5).Value
            Else
                newWS2.Cells(nRow, 1).Value = newWS1.Cells(nRow, 1).Value
                newWS2.Cells(nRow, 5).Value = newWS1.Cells(nRow, 5).Value
            End If
        ElseIf newWS1.Cells(nRow, 1).Value < newWS2.Cells(nRow, 1).Value Then
            If newWS1.Cells(nRow, 1).Value <> "" Then
                newWS2.Cells(nRow, 1).EntireRow.Insert
                newWS2.Cells(nRow, 1).Value = newWS1.Cells(nRow, 1).Value
                newWS2.Cells(nRow, 5).Value = newWS1.Cells(nRow, 5).Value
            Else
                newWS1.Cells(nRow, 1).Value = newWS2.Cells(nRow, 1).Value
                newWS1.Cells(nRow, 5).Value = newWS2.Cells(nRow, 5).Value
            End If
        Else
            If newWS1.Cells(nRow, 2).Value > newWS2.Cells(nRow, 2).Value And newWS2.Cells(nRow, 2).Value <> "" Then
                If newWS2.Cells(nRow, 2).Value <> "" Then
                    newWS1.Cells(nRow, 2).EntireRow.Insert
                    newWS1.Cells(nRow, 1).Value = newWS2.Cells(nRow, 1).Value
                    newWS1.Cells(nRow, 5).Value = newWS2.Cells(nRow, 5).Value
                Else
                    newWS2.Cells(nRow, 1).Value = newWS1.Cells(nRow, 1).Value
                    newWS2.Cells(nRow, 5).Value = newWS1.Cells(nRow, 5).Value
                End If
            ElseIf newWS1.Cells(nRow, 2).Value < newWS2.Cells(nRow, 2).Value Then
                If newWS1.Cells(nRow, 2).Value <> "" Then
                    newWS2.Cells(nRow, 2).EntireRow.Insert
                    newWS2.Cells(nRow, 1).Value = newWS1.Cells(nRow, 1).Value
                    newWS2.Cells(nRow, 5).Value = newWS1.Cells(nRow, 5).Value
                Else
                    newWS1.Cells(nRow, 1).Value = newWS2.Cells(nRow, 1).Value
                    newWS1.Cells(nRow, 5).Value = newWS2.Cells(nRow, 5).Value
                End If
            Else
                If newWS1.Cells(nRow, 3).Value > newWS2.Cells(nRow, 3).Value Then
                    If newWS2.Cells(nRow, 3).Value <> "" Then
                        newWS1.Cells(nRow, 3).EntireRow.Insert
                        newWS1.Cells(nRow, 1).Value = newWS2.Cells(nRow, 1).Value
                        newWS1.Cells(nRow, 5).Value = newWS2.Cells(nRow, 5).Value
                    Else
                        newWS2.Cells(nRow, 1).Value = newWS1.Cells(nRow, 1).Value
                        newWS2.Cells(nRow, 5).Value = newWS1.Cells(nRow, 5).Value
                    End If
                ElseIf newWS1.Cells(nRow, 3).Value < newWS2.Cells(nRow, 3).Value Then
                    If newWS1.Cells(nRow, 3).Value <> "" Then
                        newWS2.Cells(nRow, 3).EntireRow.Insert
                        newWS2.Cells(nRow, 1).Value = newWS1.Cells(nRow, 1).Value
                        newWS2.Cells(nRow, 5).Value = newWS1.Cells(nRow, 5).Value
                    Else
                        newWS1.Cells(nRow, 1).Value = newWS2.Cells(nRow, 1).Value
                        newWS1.Cells(nRow, 5).Value = newWS2.Cells(nRow, 5).Value
                    End If
                End If
            End If
        End If
        nRow = nRow + 1
    Loop
 
    newWS1.Select
    Columns("B:C").Select
    Range("B1").Activate
    Selection.Delete Shift:=xlToLeft
 
    newWS2.Select
    Columns("B:C").Select
    Range("B1").Activate
    Selection.Delete Shift:=xlToLeft
 
 
    Set balWS = Worksheets.Add(, Sheets(Sheets.Count)) 'Create a worksheet that is balanced
 
    'Copy onto new dataworksheet
    Worksheets(dataWS).Range("A1:AL7").Copy balWS.Range("A1")
    newWS1.Range("A1:S" & nRow).Copy balWS.Range("A8")
    newWS2.Range("A1:S" & nRow).Copy balWS.Range("T8")
 
    'Delete temporary worksheets
    newWS1.Delete
    newWS2.Delete
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
    End With
End Sub
 
Upvote 0
Hi, zookeeper!

I thought you disappeared and I had no way of verifying that my code works on XL 2003 haha.

I'm glad it works and thank you for your kind words lol!

Anyways, if you want to color a whole row some kind of color, just use
Rich (BB code): 
Range("A1").EntireRow.Interior.ColorIndex = 6

Basically, this will color the first row some kind of color which has an index of 6.
If you want to check out the colorindices, you can visit this website:
http://dmcritchie.mvps.org/excel/colors.htm

If you want any other colors, you might want to look into using a method such as
Rich (BB code): 
Range("A1").EntireRow.Interior.Color = RGB(255, 255, 0)
This will allow you to create 16million different colors by using combination of red, green and blue (as you would have probably guessed).

So, you can change the colors like that so here's the actual code you could use.
Rich (BB code): 
Sub kpark91May302011()
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    Dim newWS1 As Worksheet, newWS2 As Worksheet, LR1 As Double, LR2 As Double, dataWS As String
    Dim dataStartRow As Double, balWS As Worksheet
 
    dataStartRow = 8 'Data starting row
 
    dataWS = "ALL"
    On Error GoTo 0
    Set newWS1 = Worksheets.Add(, Sheets(Sheets.count))
    Set newWS2 = Worksheets.Add(, Sheets(Sheets.count)) 'Add Worksheet At the end of the workbook temporarily
 
    LR1 = Worksheets(dataWS).Range("A" & Rows.count).End(xlUp).Row
    LR2 = Worksheets(dataWS).Range("R" & Rows.count).End(xlUp).Row 'Find row # before the first occurrence of a blank cell in the column
 
    'Copy the data into two separate files
    With Worksheets(dataWS)
        .Range("A" & dataStartRow & ":Q" & LR1).Copy newWS1.Cells(1, 1) 'Copy + Paste PM's data into first temp sheet
        .Range("R" & dataStartRow & ":AH" & LR2).Copy newWS2.Cells(1, 1) 'Copy + Paste TM's data into second temp sheet
    End With
 
    'Sort colE, colD, then colA of newWS1
    newWS1.Select
    Columns("B:C").Select
    Range("B1").Activate
    Selection.Insert Shift:=xlToRight
    Columns("E:E").Select
    Range("E1").Activate
    Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="/", FieldInfo:=Array(Array(1, 1), Array(2, 9), Array(3, 1)), _
        TrailingMinusNumbers:=True
 
    newWS2.Select
    Columns("B:C").Select
    Range("B1").Activate
    Selection.Insert Shift:=xlToRight
    Columns("E:E").Select
    Range("E1").Activate
    Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="/", FieldInfo:=Array(Array(1, 1), Array(2, 9), Array(3, 1)), _
        TrailingMinusNumbers:=True
 
    newWS1.Select
    Cells.Select
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("B1") _
    , Order2:=xlAscending, Key3:=Range("C1"), Order3:=xlAscending, Header:= _
    xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
    xlSortNormal
 
    newWS2.Select
    Cells.Select
    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("B1") _
    , Order2:=xlAscending, Key3:=Range("C1"), Order3:=xlAscending, Header:= _
    xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
    xlSortNormal
 
    'Loop through both new temporary worksheets at the same time
    'Since they are sorted from A to Z, whatever has the bigger value in the same row number as the other worksheet,
    'there will be a new line added above it with the values from the smaller values copied as requested
    'however, if there is comparison between a blank cell and  0, it will be considered as equal, which may cause some problems
 
    Dim nRow As Double
    nRow = 1 'Data starts from row 1 of temporary files
 
    '''Balancing based on three criteria
    Do While Not IsEmpty(newWS1.Cells(nRow, 1).Value) Or Not IsEmpty(newWS2.Cells(nRow, 1).Value)
        If newWS1.Cells(nRow, 1).Value > newWS2.Cells(nRow, 1).Value And newWS2.Cells(nRow, 1).Value <> "" Then
            If newWS2.Cells(nRow, 1).Value <> "" Then
                newWS1.Cells(nRow, 1).EntireRow.Insert
                newWS1.Cells(nRow, 1).EntireRow.Interior.ColorIndex = 6
                newWS1.Cells(nRow, 1).Value = newWS2.Cells(nRow, 1).Value
                newWS1.Cells(nRow, 5).Value = newWS2.Cells(nRow, 5).Value
            Else
                newWS1.Cells(nRow, 1).EntireRow.Interior.ColorIndex = 6
                newWS2.Cells(nRow, 1).Value = newWS1.Cells(nRow, 1).Value
                newWS2.Cells(nRow, 5).Value = newWS1.Cells(nRow, 5).Value
            End If
        ElseIf newWS1.Cells(nRow, 1).Value < newWS2.Cells(nRow, 1).Value Then
            If newWS1.Cells(nRow, 1).Value <> "" Then
                newWS2.Cells(nRow, 1).EntireRow.Insert
                newWS1.Cells(nRow, 1).EntireRow.Interior.ColorIndex = 6
                newWS2.Cells(nRow, 1).Value = newWS1.Cells(nRow, 1).Value
                newWS2.Cells(nRow, 5).Value = newWS1.Cells(nRow, 5).Value
            Else
                newWS1.Cells(nRow, 1).EntireRow.Interior.ColorIndex = 6
                newWS1.Cells(nRow, 1).Value = newWS2.Cells(nRow, 1).Value
                newWS1.Cells(nRow, 5).Value = newWS2.Cells(nRow, 5).Value
            End If
        Else
            If newWS1.Cells(nRow, 2).Value > newWS2.Cells(nRow, 2).Value And newWS2.Cells(nRow, 2).Value <> "" Then
                If newWS2.Cells(nRow, 2).Value <> "" Then
                    newWS1.Cells(nRow, 2).EntireRow.Insert
                    newWS1.Cells(nRow, 1).EntireRow.Interior.ColorIndex = 6
                    newWS1.Cells(nRow, 1).Value = newWS2.Cells(nRow, 1).Value
                    newWS1.Cells(nRow, 5).Value = newWS2.Cells(nRow, 5).Value
                Else
                    newWS1.Cells(nRow, 1).EntireRow.Interior.ColorIndex = 6
                    newWS2.Cells(nRow, 1).Value = newWS1.Cells(nRow, 1).Value
                    newWS2.Cells(nRow, 5).Value = newWS1.Cells(nRow, 5).Value
                End If
            ElseIf newWS1.Cells(nRow, 2).Value < newWS2.Cells(nRow, 2).Value Then
                If newWS1.Cells(nRow, 2).Value <> "" Then
                    newWS2.Cells(nRow, 2).EntireRow.Insert
                    newWS1.Cells(nRow, 2).EntireRow.Interior.ColorIndex = 6
                    newWS2.Cells(nRow, 1).Value = newWS1.Cells(nRow, 1).Value
                    newWS2.Cells(nRow, 5).Value = newWS1.Cells(nRow, 5).Value
                Else
                    newWS1.Cells(nRow, 2).EntireRow.Interior.ColorIndex = 6
                    newWS1.Cells(nRow, 1).Value = newWS2.Cells(nRow, 1).Value
                    newWS1.Cells(nRow, 5).Value = newWS2.Cells(nRow, 5).Value
                End If
            Else
                If newWS1.Cells(nRow, 3).Value > newWS2.Cells(nRow, 3).Value Then
                    If newWS2.Cells(nRow, 3).Value <> "" Then
                        newWS1.Cells(nRow, 3).EntireRow.Insert
                        newWS1.Cells(nRow, 3).EntireRow.Interior.ColorIndex = 6
                        newWS1.Cells(nRow, 1).Value = newWS2.Cells(nRow, 1).Value
                        newWS1.Cells(nRow, 5).Value = newWS2.Cells(nRow, 5).Value
                    Else
                        newWS1.Cells(nRow, 3).EntireRow.Interior.ColorIndex = 6
                        newWS2.Cells(nRow, 1).Value = newWS1.Cells(nRow, 1).Value
                        newWS2.Cells(nRow, 5).Value = newWS1.Cells(nRow, 5).Value
                    End If
                ElseIf newWS1.Cells(nRow, 3).Value < newWS2.Cells(nRow, 3).Value Then
                    If newWS1.Cells(nRow, 3).Value <> "" Then
                        newWS2.Cells(nRow, 3).EntireRow.Insert
                        newWS1.Cells(nRow, 3).EntireRow.Interior.ColorIndex = 6
                        newWS2.Cells(nRow, 1).Value = newWS1.Cells(nRow, 1).Value
                        newWS2.Cells(nRow, 5).Value = newWS1.Cells(nRow, 5).Value
                    Else
                        newWS1.Cells(nRow, 3).EntireRow.Interior.ColorIndex = 6
                        newWS1.Cells(nRow, 1).Value = newWS2.Cells(nRow, 1).Value
                        newWS1.Cells(nRow, 5).Value = newWS2.Cells(nRow, 5).Value
                    End If
                End If
            End If
        End If
        nRow = nRow + 1
    Loop
 
    newWS1.Select
    Columns("B:C").Select
    Range("B1").Activate
    Selection.Delete Shift:=xlToLeft
 
    newWS2.Select
    Columns("B:C").Select
    Range("B1").Activate
    Selection.Delete Shift:=xlToLeft
 
 
    Set balWS = Worksheets.Add(, Sheets(Sheets.count)) 'Create a worksheet that is balanced
 
    'Copy onto new dataworksheet
    Worksheets(dataWS).Range("A1:AL7").Copy balWS.Range("A1")
    newWS1.Range("A1:S" & nRow).Copy balWS.Range("A8")
    newWS2.Range("A1:S" & nRow).Copy balWS.Range("T8")
 
    'Delete temporary worksheets
    newWS1.Delete
    newWS2.Delete
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
    End With
End Sub

I wasn't sure about the extra features you've left in the code so I've just left them there :P

Just fyi,
When you have something like
Rich (BB code): 
    newWS2.Select
    Columns("B:C").Select
    Range("B1").Activate
    Selection.Delete Shift:=xlToLeft

you can reduce it down to
Rich (BB code): 
newWS2.Columns("B:C").Range("B1").Delete Shift:=xlToLeft

I'm not too sure but I think it's better for the reader and it's faster to run which will be very important when you have lots of data later on:P

Good luck!!
kpark
 
Upvote 0
Hello again!

Hope you had a great weekend! I'm still down here wallowing in delight with my new "toy". I must admit that, several times, I've recreated the worksheet as it looks at the beginning & then run the macro just to watch it work, LOL! (I might be just a little TOO easy to amuse :rofl: )

Thank you again for your help with this; although "help" doesn't seem like the right word for the amount of work you did! You're SO awesome!

Also, thanks for the link for the colorindices; I'll have to study on that when I get a chance. The name in web address looked familiar; it turns out that we've been using one of David McRitchie's more basic macros for quite a while. Small world, huh?

When you have something like

Code:


newWS2.Select Columns("B:C").Select Range("B1").Activate Selection.Delete Shift:=xlToLeft
</PRE>
you can reduce it down to

Code:


newWS2.Columns("B:C").Range("B1").Delete Shift:=xlToLeft
</PRE>
I'm not too sure but I think it's better for the reader and it's faster to run which will be very important when you have lots of data later on:P
Click to expand...

I tried doing that earlier when I had recorded that macro to send you, but I was doing something wrong & fouled it up. I've cleaned up a number of my other macros before, but sometimes mess them up, too & have to put some stuff back in. I don't know how to tell what you can safely get rid of.

On another macro I had the following:
Code: 
    Columns("B:B").Select
    Selection.NumberFormat = "0"
    With Selection
        .HorizontalAlignment = xlLeft
    End With
    Columns("E:R").Select
    Selection.NumberFormat = "#,##0.00_);[Red](#,##0.00)"
    With Selection
        .HorizontalAlignment = xlRight
    End With
which worked fine. When I went to remove some of the excess & make it:
Code: 
    Columns("B:B").NumberFormat = "0"
    With Selection
        .HorizontalAlignment = xlLeft
    End With
    Columns("E:R").NumberFormat = "#,##0.00_);[Red](#,##0.00)"
    With Selection
        .HorizontalAlignment = xlRight
    End With
it would end up changing column B into right aligned. So, I ended up just swapping them, so that it formats E:R first, then B. Plus, just to be safe, I put back the
Code: 
Select
    Selection.
& then backed away carefully, so as not to upset it :nervous:. So, how do you know what you can safely remove?
 
Upvote 0
Hi, zookeeper.

The problem you're having right now with the
Rich (BB code): 
Columns("B:B").NumberFormat = "0"
    With Selection
        .HorizontalAlignment = xlLeft
    End With
    Columns("E:R").NumberFormat = "#,##0.00_);[Red](#,##0.00)"
    With Selection
        .HorizontalAlignment = xlRight
    End With

is because of With Selection.

In the code before the modification, you first selected column("B:B") but by reducing to this line of code
Rich (BB code): 
Columns("B:B").NumberFormat = "0"
,
you have removed the selection.

So, when you try to call selection, the code looks for the last selected range whether it be in the code or in the spreadsheet. To fix this problem, you can use a similar method of With.

Solution:
Replace
Rich (BB code): 
    Columns("B:B").NumberFormat = "0"
    With Selection
        .HorizontalAlignment = xlLeft
    End With

with
Rich (BB code): 
With Columns("B:B")
    .NumberFormat = "0"
    .HorizontalAlignment = xlLeft
End With

and do similar things with the other codes :)

Explanation:
So, the I've told you the reason why the code wasn't working but just for your information, With command is an easy way to reduce the length of the code and to improve the readability of the code

You could see the explanation of Windows Help:
http://msdn.microsoft.com/en-us/library/wc500chb.aspx

By using With, you can specify which object you want to use throughout the With command until you hit End With

So, here is an example of conversion from not using With to using With:
Before:
Rich (BB code): 
Worksheets("Data").Range("A1").Value = "Hi"
Worksheets("Data").Range("A1").Interior.Color = RGB(255, 255, 255)
Worksheets("Data").Range("A1").Font.Bold = True

After:
Rich (BB code): 
With Worksheets("Data").Range("A1")
    .Value = "Hi"
    .Interior.Color = RGB(255,255,255)
    .Font.Bold = True
End With


I hope it helps.
 
Upvote 0
kpark91 said:
Explanation:
So, the I've told you the reason why the code wasn't working but just for your information, With command is an easy way to reduce the length of the code and to improve the readability of the code

You could see the explanation of Windows Help:
http://msdn.microsoft.com/en-us/library/wc500chb.aspx

By using With, you can specify which object you want to use throughout the With command until you hit End With

So, here is an example of conversion from not using With to using With:
Before:
Rich (BB code): 
Worksheets("Data").Range("A1").Value = "Hi"
Worksheets("Data").Range("A1").Interior.Color = RGB(255, 255, 255)
Worksheets("Data").Range("A1").Font.Bold = True

After:
Rich (BB code): 
With Worksheets("Data").Range("A1")
    .Value = "Hi"
    .Interior.Color = RGB(255,255,255)
    .Font.Bold = True
End With


I hope it helps.
Click to expand...

Ooh, yes! Very good information, thanks! I've been wondering about all the "with", "activate", etc. I've tried reading about them, but things like that just do NOT go into my head unless I can get someone to use "non-tech" speak, LOL! Your excellent explanation makes it understandable. Thank you again for your patience and expertise! I'll be getting a big grin every time I run that macro, just thinking about what I used to have to go through.

Jenny
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Question Question
Insert Cells into Defined Range in middle of sheet surrounded with data
Replies
1
Views
178
sijpie
sijpie
U
  • Question Question
Inserting images into Excel workbook - loss of image quality problem
Replies
1
Views
445
ranman256
ranman256
X
  • Question Question
VBA for extracting specific data from PDF Docs
Replies
3
Views
728
xcellrodeo
X
S
  • Solved
When Filter is applied, Excel jumps down multiple rows to (Blanks). How can Filter ignore blanks?
Replies
3
Views
410
Peter_SSs
Peter_SSs
G
  • Question Question
V/Hlookup or Index/Match assistance Required?
Replies
7
Views
101
etaf
etaf

Forum statistics

Threads
1,224,574
Messages
6,179,629
Members
452,933
Latest member
patv

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top