View Full Version : Solved: VBA code to copy rows from one sheet to another based on 2 criteria?
Danny
03-10-2009, 07:43 PM
I am wanting to copy rows that contain certain values to another spreadsheet, but place them in 1 of 3 sections based on a second criteria. For instance if a row in sheet1 contains "D34" in column A then i want to copy it to sheet 2, but I want to place it in the PRIOR, PRESENT, or FUTURE section based on what is in column C.
So sheet1 is the info i have and sheet2 is what i ,want after it is populated.
Sheet1-
Col. A / Col. B / Col. C
1 D34 / $4.00 / Current
2 A42 / $6.34 / Prior
3 D34 / $7.09 / Prior
4 C72 / $8.78 / Future
5 D34 / $0.98 / Future
6 D34 / $9.01 / Prior
Sheet2-
Prior Section
D34 / $7.09 / Prior
D34 / $9.01 / Prior
Current Section
D34 / $4.00 / Current
Future Section
D34 / $0.98 / Future
MaximS
03-10-2009, 08:34 PM
try that:
Sub Copier()
Dim Wb As Workbook
Dim Sh, Sh1 Worksheet
Dim LRow, i, j, k, l As Long
Set Wb = ThisWorkbook
Set Sh = Wb.Worksheets(1)
Set Sh1 = Wb.Worksheets(2)
LRow = Sh.Range("A" & Rows.Count).End(xlUp).Row
'First row of Prior section
j = 2
'First row of Current section
k = 10
'First row of Future section
l = 15
With Sh
For i = 1 To LRow
If .Cells(i, "A").Value = "D34" Then
Section = .Cells(i, "C").Value
Select Case Section
Case Prior
Sh1.Range("A" & j & ":C" & j).Value = _
.Range("A" & i & ":C" & i).Value
j = j + 1
Case Current
Sh1.Range("A" & k & ":C" & k).Value = _
.Range("A" & i & ":C" & i).Value
k = k + 1
Case Future
Sh1.Range("A" & l & ":C" & l).Value = _
.Range("A" & i & ":C" & i).Value
l = l + 1
End Select
End If
Next i
End With
End Sub
Bob Phillips
03-12-2009, 04:56 AM
Public Sub ProcessData()
Const TEST_COLUMN As String = "A" '<=== change to suit
Dim i As Long
Dim LastRow As Long
Dim iPrior As Long, iCurrent As Long, iFuture As Long
Dim aryCurrent, aryPrior, aryFuture
Dim cell As Range
Dim Sh As Worksheet
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
ReDim aryPrior(1 To LastRow, 1 To 3)
ReDim aryCurrent(1 To LastRow, 1 To 3)
ReDim aryFuture(1 To LastRow, 1 To 3)
For i = 1 To LastRow
With .Cells(i, TEST_COLUMN)
Select Case .Offset(0, 2).Value
Case "Prior"
iPrior = iPrior + 1
aryPrior(iPrior, 1) = .Value
aryPrior(iPrior, 2) = .Offset(0, 1).Value
aryPrior(iPrior, 3) = .Offset(0, 2).Value
Case "Current"
iCurrent = iCurrent + 1
aryCurrent(iCurrent, 1) = .Value
aryCurrent(iCurrent, 2) = .Offset(0, 1).Value
aryCurrent(iCurrent, 3) = .Offset(0, 2).Value
Case "Future"
iFuture = iFuture + 1
aryFuture(iFuture, 1) = .Value
aryFuture(iFuture, 2) = .Offset(0, 1).Value
aryFuture(iFuture, 3) = .Offset(0, 2).Value
End Select
End With
Next i
End With
With Worksheets("Sheet2")
.Range("A1").Value = "Prior Section"
.Range("A2").Resize(iPrior, 3) = aryPrior
.Cells(iPrior + 3, "A").Value = "Current Section"
.Cells(iPrior + 4, "A").Resize(iCurrent, 3) = aryCurrent
.Cells(iPrior + iCurrent + 5, "A").Value = "Future Section"
.Cells(iPrior + iCurrent + 6, "A").Resize(iFuture, 3) = aryCurrent
End With
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Danny
03-12-2009, 06:17 AM
XLD,
Thank you. That is a pretty impressive code. The only other thing is that i am wanting to copy only the rows that contain "D34" in column A. And the Value ("D34") that acts as the criteria for whether or not to copy will be derived from a cell on sheet3.range("A1"). So, for example if the value in Sheet3.Range("A1") is "D34" then only the rows containing "D34" in column A of Sheet1 would move to Sheet2 in one of the 3 Sections.
I have been trying to do this with an IF, THEN statement to compare these values inside of a FOR EACH , IN , NEXT, but i am not having much luck.
Any more ideas you might have would be greatly appretiated.
Thanks again,
Danny
Bob Phillips
03-12-2009, 06:21 AM
Public Sub ProcessData()
Const TEST_COLUMN As String = "A" '<=== change to suit
Dim i As Long
Dim LastRow As Long
Dim iPrior As Long, iCurrent As Long, iFuture As Long
Dim aryCurrent, aryPrior, aryFuture
Dim CheckValue As String
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
CheckValue = Worksheets("Sheet3").Range("A1").Value
With Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
ReDim aryPrior(1 To LastRow, 1 To 3)
ReDim aryCurrent(1 To LastRow, 1 To 3)
ReDim aryFuture(1 To LastRow, 1 To 3)
For i = 1 To LastRow
With .Cells(i, TEST_COLUMN)
If .Value = CheckValue Then
Select Case .Offset(0, 2).Value
Case "Prior"
iPrior = iPrior + 1
aryPrior(iPrior, 1) = .Value
aryPrior(iPrior, 2) = .Offset(0, 1).Value
aryPrior(iPrior, 3) = .Offset(0, 2).Value
Case "Current"
iCurrent = iCurrent + 1
aryCurrent(iCurrent, 1) = .Value
aryCurrent(iCurrent, 2) = .Offset(0, 1).Value
aryCurrent(iCurrent, 3) = .Offset(0, 2).Value
Case "Future"
iFuture = iFuture + 1
aryFuture(iFuture, 1) = .Value
aryFuture(iFuture, 2) = .Offset(0, 1).Value
aryFuture(iFuture, 3) = .Offset(0, 2).Value
End Select
End If
End With
Next i
End With
With Worksheets("Sheet2")
.Columns("A:C").ClearContents
.Range("A1").Value = "Prior Section"
If Not IsEmpty(aryPrior(1, 1)) Then .Range("A2").Resize(iPrior, 3) = aryPrior
.Cells(iPrior + 3, "A").Value = "Current Section"
If Not IsEmpty(aryCurrent(1, 1)) Then .Cells(iPrior + 4, "A").Resize(iCurrent, 3) = aryCurrent
.Cells(iPrior + iCurrent + 5, "A").Value = "Future Section"
If Not IsEmpty(aryFuture(1, 1)) Then .Cells(iPrior + iCurrent + 6, "A").Resize(iFuture, 3) = aryCurrent
End With
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Danny
03-12-2009, 06:42 AM
xld,
You are brilliant!!
the only thing is that it is not picking up the future section. I am trying to figure out why but i am pretty new to VBA and am having trouble keeping up with your codes.
thanks again.
Bob Phillips
03-12-2009, 06:50 AM
It picks up Future for me. I have just run it again for D34 and that is showing the #4.00 amount.
Bob Phillips
03-12-2009, 07:35 AM
Just spotted tyhe problem, I was dropping the Current array into the Future section (copy paste error)
Public Sub ProcessData()
Const TEST_COLUMN As String = "A" '<=== change to suit
Dim i As Long
Dim LastRow As Long
Dim iPrior As Long, iCurrent As Long, iFuture As Long
Dim aryCurrent, aryPrior, aryFuture
Dim CheckValue As String
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
CheckValue = Worksheets("Sheet3").Range("A1").Value
With Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
ReDim aryPrior(1 To LastRow, 1 To 3)
ReDim aryCurrent(1 To LastRow, 1 To 3)
ReDim aryFuture(1 To LastRow, 1 To 3)
For i = 1 To LastRow
With .Cells(i, TEST_COLUMN)
If .Value = CheckValue Then
Select Case .Offset(0, 2).Value
Case "Prior"
iPrior = iPrior + 1
aryPrior(iPrior, 1) = .Value
aryPrior(iPrior, 2) = .Offset(0, 1).Value
aryPrior(iPrior, 3) = .Offset(0, 2).Value
Case "Current"
iCurrent = iCurrent + 1
aryCurrent(iCurrent, 1) = .Value
aryCurrent(iCurrent, 2) = .Offset(0, 1).Value
aryCurrent(iCurrent, 3) = .Offset(0, 2).Value
Case "Future"
iFuture = iFuture + 1
aryFuture(iFuture, 1) = .Value
aryFuture(iFuture, 2) = .Offset(0, 1).Value
aryFuture(iFuture, 3) = .Offset(0, 2).Value
End Select
End If
End With
Next i
End With
With Worksheets("Sheet2")
.Columns("A:C").ClearContents
.Range("A1").Value = "Prior Section"
If Not IsEmpty(aryPrior(1, 1)) Then .Range("A2").Resize(iPrior, 3) = aryPrior
.Cells(iPrior + 3, "A").Value = "Current Section"
If Not IsEmpty(aryCurrent(1, 1)) Then .Cells(iPrior + 4, "A").Resize(iCurrent, 3) = aryCurrent
.Cells(iPrior + iCurrent + 5, "A").Value = "Future Section"
If Not IsEmpty(aryFuture(1, 1)) Then .Cells(iPrior + iCurrent + 6, "A").Resize(iFuture, 3) = aryFuture
End With
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
rinser
03-12-2009, 08:06 AM
I wish the presented code would have some more comments. I am newbie and would really appreciate if the steps and logic would be explained.
The code looks quite impressive, I wish I could understand it all... :(
Bob Phillips
03-12-2009, 09:10 AM
Sorry, I don't do comments.
Danny
03-17-2009, 05:40 AM
I have added a little bit to the code. Now i am wanting to add some formulas. Also, any ideas to clean up or simplify this code would be appreciated.
I am wanting column H to contain a formula that subtracts column G (the value in column G will be added manually after the sub runs) from column F (H=F-G) for each row.
I would also like to total the columns F, G, H for each section ( Prior,Current, Future). Then a Row at the bottom that adds those 3 totals.
Thanks,
Danny
Public Sub ProcessData5()
Const TEST_COLUMN As String = "B" '<=== change to suit
Dim i As Long
Dim LastRow As Long
Dim iPrior As Long, iCurrent As Long, iFuture As Long
Dim aryCurrent, aryPrior, aryFuture
Dim aryHdr
Dim CheckValue As String
Dim Wb As Workbook
Set Wb = ThisWorkbook
Ahdr = "SERVNBR"
Bhdr = "INVNBR"
Chdr = "BLK"
Dhdr = "LN#"
Ehdr = "CHL LOAN#"
Fhdr = "LN LOSS AMT"
Ghdr = "APPROVED"
Hhdr = "DIFFERENCE"
iHdr = "Description"
Jhdr = "Comments"
Khdr = "Comments2"
ReDim aryHdr(1, 1 To 11)
aryHdr(0, 1) = Ahdr
aryHdr(0, 2) = Bhdr
aryHdr(0, 3) = Chdr
aryHdr(0, 4) = Dhdr
aryHdr(0, 5) = Ehdr
aryHdr(0, 6) = Fhdr
aryHdr(0, 7) = Ghdr
aryHdr(0, 8) = Hhdr
aryHdr(0, 9) = iHdr
aryHdr(0, 10) = Jhdr
aryHdr(0, 11) = Khdr
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
CheckValue = Wb.Worksheets(2).Range("A1").Value
With Wb.Worksheets(1)
LastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
ReDim aryPrior(1 To LastRow, 1 To 13)
ReDim aryCurrent(1 To LastRow, 1 To 13)
ReDim aryFuture(1 To LastRow, 1 To 13)
For i = 1 To LastRow
With .Cells(i, TEST_COLUMN)
If .Value = CheckValue Then
Select Case .Offset(0, -1).Value
Case "CM FL"
iPrior = iPrior + 1
aryPrior(iPrior, 1) = .Value
aryPrior(iPrior, 2) = .Offset(0, 1).Value
aryPrior(iPrior, 3) = .Offset(0, 2).Value
aryPrior(iPrior, 4) = .Offset(0, 3).Value
aryPrior(iPrior, 5) = .Offset(0, 4).Value
aryPrior(iPrior, 6) = .Offset(0, 5).Value
aryPrior(iPrior, 7) = .Offset(0, 6).Value
aryPrior(iPrior, 8) = .Offset(0, 7).Value '(F-G)
aryPrior(iPrior, 9) = .Offset(0, 8).Value
aryPrior(iPrior, 10) = .Offset(0, 9).Value
aryPrior(iPrior, 11) = .Offset(0, 10).Value
aryPrior(iPrior, 12) = .Offset(0, 11).Value
aryPrior(iPrior, 13) = .Offset(0, 12).Value
Case "Supp"
iCurrent = iCurrent + 1
aryCurrent(iCurrent, 1) = .Value
aryCurrent(iCurrent, 2) = .Offset(0, 1).Value
aryCurrent(iCurrent, 3) = .Offset(0, 2).Value
aryCurrent(iCurrent, 4) = .Offset(0, 3).Value
aryCurrent(iCurrent, 5) = .Offset(0, 4).Value
aryCurrent(iCurrent, 6) = .Offset(0, 5).Value
aryCurrent(iCurrent, 7) = .Offset(0, 6).Value
aryCurrent(iCurrent, 8) = .Offset(0, 7).Value '(F-G)
aryCurrent(iCurrent, 9) = .Offset(0, 8).Value
aryCurrent(iCurrent, 10) = .Offset(0, 9).Value
aryCurrent(iCurrent, 11) = .Offset(0, 10).Value
aryCurrent(iCurrent, 12) = .Offset(0, 11).Value
aryCurrent(iCurrent, 13) = .Offset(0, 12).Value
Case "RA"
iFuture = iFuture + 1
aryFuture(iFuture, 1) = .Value
aryFuture(iFuture, 2) = .Offset(0, 1).Value
aryFuture(iFuture, 3) = .Offset(0, 2).Value
aryFuture(iFuture, 4) = .Offset(0, 3).Value
aryFuture(iFuture, 5) = .Offset(0, 4).Value
aryFuture(iFuture, 6) = .Offset(0, 5).Value
aryFuture(iFuture, 7) = .Offset(0, 6).Value
aryFuture(iFuture, 8) = .Offset(0, 7).Value ' (F-G)
aryFuture(iFuture, 9) = .Offset(0, 8).Value
aryFuture(iFuture, 10) = .Offset(0, 9).Value
aryFuture(iFuture, 11) = .Offset(0, 10).Value
aryFuture(iFuture, 12) = .Offset(0, 11).Value
aryFuture(iFuture, 13) = .Offset(0, 12).Value
End Select
End If
End With
Next i
End With
Workbooks.Add (xlWBATWorksheet)
ChDir "C:\Users\Owner\Desktop"
ActiveWorkbook.SaveAs Filename:="C:\Users\Owner\Desktop\" & CheckValue & ".xls", _
FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
With Workbooks(CheckValue).Worksheets(1)
.Range("A1").Value = "Prior"
.Range("A1").Font.Bold = True
If Not IsEmpty(aryPrior(1, 1)) Then .Range("A2").Resize(iPrior, 13) = aryHdr
If Not IsEmpty(aryPrior(1, 1)) Then .Range("A2").EntireRow.Interior.ColorIndex = 4
If Not IsEmpty(aryPrior(1, 1)) Then .Range("A3").Resize(iPrior, 13) = aryPrior
'Total Columns F,G &H
.Cells(iPrior + 3, "A").Value = "PriorTotal"
.Cells(iPrior + 3, "A").Font.Bold = True
.Cells(iPrior + 3, "A").Font.Underline = True
.Cells(iPrior + 3, "A").EntireRow.Interior.ColorIndex = 8
.Cells(iPrior + 7, "A").Value = "Current"
.Cells(iPrior + 7, "A").Font.Bold = True
If Not IsEmpty(aryCurrent(1, 1)) Then .Cells(iPrior + 8, "A").Resize(iCurrent, 13) = aryHdr
If Not IsEmpty(aryCurrent(1, 1)) Then .Cells(iPrior + 8, "A").EntireRow.Interior.ColorIndex = 4
If Not IsEmpty(aryCurrent(1, 1)) Then .Cells(iPrior + 9, "A").Resize(iCurrent, 13) = aryCurrent
'Total Columns F,G &H
.Cells(iPrior + iCurrent + 9, "A").Value = "Current TOTAL"
.Cells(iPrior + iCurrent + 9, "A").Font.Bold = True
.Cells(iPrior + iCurrent + 9, "A").Font.Underline = True
.Cells(iPrior + iCurrent + 9, "A").EntireRow.Interior.ColorIndex = 8
.Cells(iPrior + iCurrent + 12, "A").Value = "Future"
.Cells(iPrior + iCurrent + 12, "A").Font.Bold = True
If Not IsEmpty(aryFuture(1, 1)) Then .Cells(iPrior + iCurrent + 13, "A").Resize(iFuture, 13) = aryHdr
If Not IsEmpty(aryFuture(1, 1)) Then .Cells(iPrior + iCurrent + 13, "A").EntireRow.Interior.ColorIndex = 4
If Not IsEmpty(aryFuture(1, 1)) Then .Cells(iPrior + iCurrent + 14, "A").Resize(iFuture, 13) = aryFuture
'Total Columns F,G &H
.Cells(iPrior + iCurrent + iFuture + 14, "A").Value = "Future Total"
.Cells(iPrior + iCurrent + iFuture + 14, "A").Font.Bold = True
.Cells(iPrior + iCurrent + iFuture + 14, "A").Font.Underline = True
.Cells(iPrior + iCurrent + iFuture + 14, "A").EntireRow.Interior.ColorIndex = 8
End With
Workbooks(CheckValue).Save
Workbooks(CheckValue).Close
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
mdmackillop
03-17-2009, 02:21 PM
Instead of
aryPrior(iPrior, 1) = .Value
aryPrior(iPrior, 2) = .Offset(0, 1).Value
aryPrior(iPrior, 3) = .Offset(0, 2).Value
aryPrior(iPrior, 4) = .Offset(0, 3).Value
aryPrior(iPrior, 5) = .Offset(0, 4).Value
aryPrior(iPrior, 6) = .Offset(0, 5).Value
aryPrior(iPrior, 7) = .Offset(0, 6).Value
aryPrior(iPrior, 8) = .Offset(0, 7).Value '(F-G)
aryPrior(iPrior, 9) = .Offset(0, 8).Value
aryPrior(iPrior, 10) = .Offset(0, 9).Value
aryPrior(iPrior, 11) = .Offset(0, 10).Value
aryPrior(iPrior, 12) = .Offset(0, 11).Value
aryPrior(iPrior, 13) = .Offset(0, 12).Value
why not loop
For x = 1 To 13
aryPrior(iPrior, x) = .Offset(0, x - 1).Value
Next
Anomandaris
03-18-2009, 03:04 AM
I'm confused, I just tried this , this code doesnt copy anything except the title of the different sections 'Prior' 'Current' and Future'
Bob Phillips
03-18-2009, 03:11 AM
why not loop
For x = 1 To 13
aryPrior(iPrior, x) = .Offset(0, x - 1).Value
Next
Because it is slower and obfuscates the code.
With the number of array items, I would create a separate proedure to load a variable first dimension, and call that passing the dimension index.
Bob Phillips
03-18-2009, 03:27 AM
I'm confused, I just tried this , this code doesnt copy anything except the title of the different sections 'Prior' 'Current' and Future'
The data layout has changed from that originally shown.
Danny
03-18-2009, 06:27 AM
My apologies to everyone. I posted the wrong code (and really confused things). Hopefully this will make more sense.
I am wanting column E to contain a formula that subtracts column D (the value in column D MAY be added or changed manually after the sub runs) from column B (E=B-D) for each row.
I would also like to total the columns B, D and E for each section (Prior, Current, Future). Then a Row grand total at the bottom that Totals B, D and E for all 3 sections.
Thanks,
Danny
Sheet3
Cell A1 contains the CheckValue of D34
Sheet1-
Col. A / Col. B / Col. C /Col. D
1 D34 / $4.00 / Current /$2.00
2 A42 / $6.34 / Prior /$4.35
3 D34 / $7.09 / Prior /$7.09
4 C72 / $8.78 / Future /$6.45
5 D34 / $0.98 / Future /$0.00
6 D34 / $9.01 / Prior /$7.98
Sheet2- ‘(AS IT IS NOW WITH THIS CODE)
Col. A / Col. B / Col. C /Col. D
Prior Section
D34 / $7.09 / Prior /$7.09
D34 / $9.01 / Prior /$7.98
Current Section
D34 / $4.00 / Current/$2.00
Future Section
D34 / $0.98 / Future /$0.00
Sheet2 ‘(THE DESIRED OUTCOME)
Col. A / Col. B / Col. C /Col. D /Col. E
Prior Section
D34 / $7.09 / Prior /$7.09 /$0.00
D34 / $9.01 / Prior /$7.98 /$1.03
Total/$16.10/" " /$15.07 /$1.03 ‘(Total Col. B,D & E for Prior)
Current Section
D34 / $4.00 / Current/$2.00 /$2.00
Total/$4.00 /" " /$2.00 /$2.00 ‘(Total Col. B,D & E for Current)
Future Section
D34 / $0.98 / Future /$0.00 /$0.98
Total/$$0.98/" " /$0.00 /$0.98 ‘(Total Col. B,D & E for Future)
Grand Total
Totals/$21.08/" " /$17.07 /$4.01 '(Total Col. B,D & E for ALL sections)
Here is the code so far.
Public Sub ProcessData()
Const TEST_COLUMN As String = "A" '<=== change to suit
Dim i As Long
Dim LastRow As Long
Dim iPrior As Long, iCurrent As Long, iFuture As Long
Dim aryCurrent, aryPrior, aryFuture
Dim CheckValue As String
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
CheckValue = Worksheets("Sheet3").Range("A1").Value
With Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, TEST_COLUMN).End(xlUp).Row
ReDim aryPrior(1 To LastRow, 1 To 5)
ReDim aryCurrent(1 To LastRow, 1 To 5)
ReDim aryFuture(1 To LastRow, 1 To 5)
For i = 1 To LastRow
With .Cells(i, TEST_COLUMN)
If .Value = CheckValue Then
Select Case .Offset(0, 2).Value
Case "Prior"
iPrior = iPrior + 1
aryPrior(iPrior, 1) = .Value
aryPrior(iPrior, 2) = .Offset(0, 1).Value
aryPrior(iPrior, 3) = .Offset(0, 2).Value
aryPrior(iPrior, 4) = .Offset(0, 3).Value
aryPrior(iPrior, 5) = .Offset(0, 4).Value ' (NOTE TO EXPLAIN WHAT NEEDS TO BE DONE) This Needs to = Columns B-D
Case "Current"
iCurrent = iCurrent + 1
aryCurrent(iCurrent, 1) = .Value
aryCurrent(iCurrent, 2) = .Offset(0, 1).Value
aryCurrent(iCurrent, 3) = .Offset(0, 2).Value
aryCurrent(iCurrent, 4) = .Offset(0, 3).Value
aryCurrent(iCurrent, 5) = .Offset(0, 4).Value ' (NOTE TO EXPLAIN WHAT NEEDS TO BE DONE) This Needs to = Columns B-D
Case "Future"
iFuture = iFuture + 1
aryFuture(iFuture, 1) = .Value
aryFuture(iFuture, 2) = .Offset(0, 1).Value
aryFuture(iFuture, 3) = .Offset(0, 2).Value
aryFuture(iFuture, 4) = .Offset(0, 3).Value
aryFuture(iFuture, 5) = .Offset(0, 4).Value ' (NOTE TO EXPLAIN WHAT NEEDS TO BE DONE) This Needs to = Columns B-D
End Select
End If
End With
Next i
End With
With Worksheets("Sheet2")
.Columns("A:E").ClearContents
.Range("A1").Value = "Prior Section"
If Not IsEmpty(aryPrior(1, 1)) Then .Range("A2").Resize(iPrior, 5) = aryPrior
'''''''' (NOTE TO EXPLAIN WHAT NEEDS TO BE DONE) Row to Total Columns B,D & E for Prior section
.Cells(iPrior + 3, "A").Value = "Current Section"
If Not IsEmpty(aryCurrent(1, 1)) Then .Cells(iPrior + 4, "A").Resize(iCurrent, 5) = aryCurrent
'''''''' (NOTE TO EXPLAIN WHAT NEEDS TO BE DONE) Row to Total Columns B,D & E for Current section
.Cells(iPrior + iCurrent + 5, "A").Value = "Future Section"
If Not IsEmpty(aryFuture(1, 1)) Then .Cells(iPrior + iCurrent + 6, "A").Resize(iFuture, 5) = aryFuture
'''''''' (NOTE TO EXPLAIN WHAT NEEDS TO BE DONE) Row to Total Columns B,D & E for Future section
'''''''' (NOTE TO EXPLAIN WHAT NEEDS TO BE DONE) Row to Total Columns B,D & E for All sections
End With
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub[/font]
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.