Sort and align 2 ranges
 

From one period to the next, some new codes charges will be active
and some previously active codes will not.
I need to merge and sort the current period with the previous period
data,
calculate the gain and trend from the previous period.
My problem in the code below, is after the merging, for the final
sorting,
if one period row of data needs to be shifted, either range "A:C" or
range "D:F"
I do not know how to address the range.
...................................
Period 1
Code %Val %Prog
B1 50 55
D2 60 54
E1 72 72
G3 70 62
.............................
Period 2
Code %Val %Prog
A1 15 10
B1 56 64
D2 68 60
F3 84 86
G3
..............................
E1 was not active in Period 2, but new codes A1 & F3 did.
Desired result after Merge & Sort :
A B C D E F
G H I
Code %Val %Prog Code %Val %Prog ValGain ProgGain PeriodTrend
A1 15
10
B1 50 55 B1 56 64
6 9 1.5
D2 60 54 D2 68 60
8 6 .75
E1 72 72
F3 87 89
G3 70 62 G3 75 67 5
5 1.0
.................................................. .
Sub SortandAlign2Ranges()
Application.ScreenUpdating = False
Workbooks.Add
ActiveWorkbook.SaveAs "c:\bookc.xls"
Workbooks.Open "c:\booka.xls"
Workbooks("booka.xls").Worksheets(1).Range("A:C"). Copy
Workbooks("bookc.xls").Activate
Sheets(1).Cells(1, 1).Select
Workbooks("bookc.xls").Sheets(1).Paste
Application.CutCopyMode = False
Application.DisplayAlerts = False
Workbooks("booka.xls").Close
Application.DisplayAlerts = True
Workbooks.Open "c:\bookb.xls"
Workbooks("bookb.xls").Worksheets(1).Range("A:C"). Copy
Workbooks("bookc.xls").Activate
Sheets(1).Cells(1, 4).Select
Workbooks("bookc.xls").Sheets(1).Paste
Application.CutCopyMode = False
Application.DisplayAlerts = False
Workbooks("bookb.xls").Close
Application.DisplayAlerts = True
CompareAndShift "A:C", "D:F"
Application.ScreenUpdating = True
End Sub
.................................................. ............ Note :
Above code works fine
Sub CompareAndShift(LRange As String, Rrange As String)
Dim aRow As Integer, bRow As Integer
Dim ShortCol As String
Dim LastRowL As Integer, LastRowR As Integer
Dim LCol As String, RCol As String
LCol = Left(LRange, 1)
RCol = Left(Rrange, 1)
Columns(LRange).Sort Key1:=Range(LCol & 1), Order1:=xlAscending
Columns(Rrange).Sort Key1:=Range(RCol & 1), Order1:=xlAscending
LastRowL = Cells(Rows.Count, LCol).End(xlUp).Row
LastRowR = Cells(Rows.Count, RCol).End(xlUp).Row
If LastRowL LastRowR Then
bRow = LastRowL
ShortCol = RCol
Else
bRow = LastRowR
ShortCol = LCol
End If
'================================= Note : Above sorting code works
fine
For aRow = bRow To 1 Step -1
If Cells(aRow, LCol) = Cells(bRow, RCol) Or Cells(bRow, ShortCol)
= "" Then
'do nothing
ElseIf Cells(aRow, LCol) < Cells(bRow, RCol) Then
ShiftIt bRow, RCol, aRow, LCol
'=====Problem starts here. In the above line, how do I instruct the
current row
' to be shifted for range "D:F"
' Same logic after the Else below, for
range "A:C"
Else
ShiftIt aRow, LCol, bRow, RCol
End If
bRow = bRow - 1
'Calculate Gain & Trend
If Cells(aRow, LCol) = Cells(bRow, RCol)
'Store Value Gain : "E" Col value - "B" Col value in
"G" Col
'Store Progtress Gain : "F" Col value - "C" Col value in
"H" Col
'Store Trend : ("H" Col value / "G" Col value)
in "I" Col
End If
Next aRow
End Sub
..................................................
Sub ShiftIt(PrimaryShift As Integer, PSCol As String, SecondaryShift
As Integer, SSCol As String)
Cells(PrimaryShift, PSCol).Insert shift:=xlDown
If Cells(SecondaryShift + 1, SSCol) < Cells(PrimaryShift + 1,
PSCol) Then
Cells(SecondaryShift + 1, SSCol).Insert shift:=xlDown
Else
Cells(PrimaryShift + 2, PSCol).Delete shift:=xlUp
End If
End Sub

Sort and align 2 ranges
 

On Jun 24, 4:39*pm, u473 wrote:
From one period to the next, some new codes charges will be active
and some previously active codes will not.
I need to merge and sort the current period with the previous period
data,
calculate the gain and trend from the previous period.
My problem in the code below, is after the merging, for the final
sorting,
if one period row of data needs to be shifted, either range "A:C" or
range "D:F"
I do not know how to address the range.
..................................
Period 1
Code *%Val *%Prog
B1 * * * *50 * * * 55
D2 * * * *60 * * * 54
E1 * * * *72 * * * 72
G3 * * * *70 * * * 62
............................
Period 2
Code *%Val *%Prog
A1 * * * *15 * * * 10
B1 * * * *56 * * * 64
D2 * * * *68 * * * 60
F3 * * * *84 * * * 86
G3
.............................
E1 was not active in Period 2, but new codes A1 & F3 did.
Desired result after Merge & Sort :
A * * * * *B * * * *C * * * * *D * * * E * * * * F
G * * * * * *H * * * * * * * * I
Code *%Val *%Prog *Code *%Val *%Prog ValGain *ProgGain PeriodTrend
* * * * * * * * * * * * * * * * * A1 * * *15
10
B1 * * * *50 * * * 55 * * * *B1 * * *56 * * * 64
6 * * * * * *9 * * * * * * * * 1.5
D2 * * * *60 * * * 54 * * * *D2 * * *68 * * * 60
8 * * * * * *6 * * * * * * * * *.75
E1 * * * *72 * * * 72
* * * * * * * * * * * * * * * * * F3 * * *87 * * * 89
G3 * * * *70 * * * 62 * * * G3 * * *75 * * * 67 * * * * * *5
5 * * * * * * * * 1.0
..................................................
Sub SortandAlign2Ranges()
*Application.ScreenUpdating = False
* * Workbooks.Add
* * ActiveWorkbook.SaveAs "c:\bookc.xls"
* * Workbooks.Open "c:\booka.xls"
* * Workbooks("booka.xls").Worksheets(1).Range("A:C"). Copy
* * Workbooks("bookc.xls").Activate
* * Sheets(1).Cells(1, 1).Select
* * Workbooks("bookc.xls").Sheets(1).Paste
* * Application.CutCopyMode = False
* * Application.DisplayAlerts = False
* * Workbooks("booka.xls").Close
* * Application.DisplayAlerts = True
* * Workbooks.Open "c:\bookb.xls"
* * Workbooks("bookb.xls").Worksheets(1).Range("A:C"). Copy
* * Workbooks("bookc.xls").Activate
* * Sheets(1).Cells(1, 4).Select
* * Workbooks("bookc.xls").Sheets(1).Paste
* * Application.CutCopyMode = False
* * Application.DisplayAlerts = False
* * Workbooks("bookb.xls").Close
* * Application.DisplayAlerts = True
* * CompareAndShift "A:C", "D:F"
* * Application.ScreenUpdating = True
End Sub
.................................................. ........... Note :
Above code works fine
Sub CompareAndShift(LRange As String, Rrange As String)
Dim aRow As Integer, bRow As Integer
Dim ShortCol As String
Dim LastRowL As Integer, LastRowR As Integer
Dim LCol As String, RCol As String
LCol = Left(LRange, 1)
RCol = Left(Rrange, 1)
Columns(LRange).Sort Key1:=Range(LCol & 1), Order1:=xlAscending
Columns(Rrange).Sort Key1:=Range(RCol & 1), Order1:=xlAscending
LastRowL = Cells(Rows.Count, LCol).End(xlUp).Row
LastRowR = Cells(Rows.Count, RCol).End(xlUp).Row
If LastRowL LastRowR Then
* * bRow = LastRowL
* * ShortCol = RCol
Else
* * bRow = LastRowR
* * ShortCol = LCol
End If
'================================= Note : Above sorting code works
fine
For aRow = bRow To 1 Step -1
* * If Cells(aRow, LCol) = Cells(bRow, RCol) Or Cells(bRow, ShortCol)
= "" Then
* * * * 'do nothing
* * ElseIf Cells(aRow, LCol) < Cells(bRow, RCol) Then
* * * * ShiftIt bRow, RCol, aRow, LCol
'=====Problem starts here. *In the above line, how do I instruct the
current row
' * * * * * * * * * * * * * * to be shifted for range "D:F"
' * * * * * * * * * * * * * * Same logic after the Else below, for
range "A:C"
* *Else
* * * * ShiftIt aRow, LCol, bRow, RCol
* *End If
* * bRow = bRow - 1
* *'Calculate Gain & Trend
* *If Cells(aRow, LCol) = Cells(bRow, RCol)
* * * 'Store Value Gain * * *: *"E" Col value - "B" Col value * * *in
"G" Col
* * * 'Store Progtress Gain : *"F" Col value - "C" Col value * * in
"H" Col
* * * 'Store Trend * * * * * * * : *("H" Col value / *"G" Col value)
in "I" Col
* *End If
Next aRow
End Sub
.................................................
Sub ShiftIt(PrimaryShift As Integer, PSCol As String, SecondaryShift
As Integer, SSCol As String)
* * Cells(PrimaryShift, PSCol).Insert shift:=xlDown
* * If Cells(SecondaryShift + 1, SSCol) < Cells(PrimaryShift + 1,
PSCol) Then
* * * * Cells(SecondaryShift + 1, SSCol).Insert shift:=xlDown
* * Else
* * * * Cells(PrimaryShift + 2, PSCol).Delete shift:=xlUp
* * End If
End Sub

"If desired, send your fileS to dguillett @gmail.com 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."