Help, can you have two arrays?

D

DanielleVBANewbie

Happy Friday Friends,

OK. I think I am in the home stretch on this project. Under the code that
ends with line: "OutSH.Cells(OutRow, "K").Value = .Cells(i, "O").Value", I
need to figure out how to add code that says basically:

If on sheet "Criteria" (CriteriaSH in the code) cell B5 = Yes, also copy
over the value in columns A, D, P, E, BP, BR, O, for rows (3, 18, 19, 43, 56,
57, 58, 59, 88) from sheet Master Template (Template SH in the Code) to
Internal Project Plan (OutSH) into same columns from the code above this
line.

I was thinking this would be accomplished with an Array but there is already
1 array below. How can I fix this?

Dim OutSH As Worksheet, TemplateSH As Worksheet, ce As Variant
Dim OutRow As Long, i As Long
Dim arr As Variant
Dim CopyRow As Boolean
Set OutSH = Sheets("Internal Project Plan")
Set TemplateSH = Sheets("Master Template")

'----------------- ADDED ------------------------------------
Dim CriteriaSH As Worksheet
Dim Timeline As Long
Set CriteriaSH = Sheets("Criteria")

Timeline = CriteriaSH.Range("B6")

If Timeline <> 60 And _
Timeline <> 90 And _
Timeline <> 120 Then

MsgBox ("Incorrect TimeLine")
Exit Sub
End If
'----------------- END ------------------------------------


With TemplateSH
For i = 2 To 700
CopyRow = False
For Each ce In CriteriaSH.Range("B15:B80")
If ce = "Yes" Then

'------------------ CHANGED FROM WORKSHEET FUNCTION -------------
Dim C As Variant
Set C = TemplateSH.Rows("1:1").Find( _
what:=ce.Offset(0, -1).Value, _
LookIn:=xlValues, _
lookat:=xlWhole)
If C Is Nothing Then
MsgBox ("Could not find : " & _
ce.Offset(0, -1).Value)
Exit Sub
Else
If .Cells(i, C.Column).Value = "x" Then
CopyRow = True
Exit For
End If
End If
End If
Next ce

If CopyRow = True Then
OutRow = OutSH.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
OutSH.Cells(OutRow, "A").Value = .Cells(i, "A").Value
OutSH.Cells(OutRow, "B").Value = .Cells(i, "D").Value
OutSH.Cells(OutRow, "C").Value = .Cells(i, "P").Value
OutSH.Cells(OutRow, "D").Value = .Cells(i, "E").Value
OutSH.Cells(OutRow, "I").Value = .Cells(i, "BP").Value
OutSH.Cells(OutRow, "J").Value = .Cells(i, "BR").Value
OutSH.Cells(OutRow, "K").Value = .Cells(i, "O").Value

'--------------------------- New Code -----------------------
Select Case Timeline

Case 60
OutSH.Cells(OutRow, "E").Value = _
.Cells(i, "H").Value
Case 90
OutSH.Cells(OutRow, "E").Value = _
.Cells(i, "K").Value
Case 120
OutSH.Cells(OutRow, "E").Value = _
.Cells(i, "N").Value
End Select
End If
'---------------------------End ----------------------------- End If
Next i
End With


'----------------------------------------------------------------
Application.StatusBar = "Transferring Headings"
arr = Array(2, 16, 85, 97, 98, 111, 127, 145, 160, 185, 193, 196, 211,
241, 308, 329, 340, 433, 447, 451, 476, 522, 549, 568, 597)


'moved outrow to this location and added counter inside loop
OutRow = OutSH.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row
With TemplateSH
For i = LBound(arr) To UBound(arr)

.Cells(arr(i), "A").Copy _
Destination:=OutSH.Cells(OutRow, "A")

'Duplicate of above row, eliminate
'OutSH.Cells(OutRow, "A").Value = .Cells(arr(i), "A").Value

.Cells(arr(i), "D").Copy _
Destination:=OutSH.Cells(OutRow, "B")

'Duplicate of above row, eliminate
'OutSH.Cells(OutRow, "B").Value = .Cells(arr(i), "D").Value

.Cells(arr(i), "J").Copy _
Destination:=OutSH.Cells(OutRow, "C")

'Duplicate of above row, eliminate
'OutSH.Cells(OutRow, "C").Value = .Cells(arr(i), "J").Value

.Cells(arr(i), "E").Copy _
Destination:=OutSH.Cells(OutRow, "D")

'Duplicate of above row, eliminate
'OutSH.Cells(OutRow, "D").Value = .Cells(arr(i), "E").Value


.Cells(arr(i), "BP").Copy _
Destination:=OutSH.Cells(OutRow, "I")

'Duplicate of above row, eliminate
'OutSH.Cells(OutRow, "I").Value = .Cells(arr(i), "BQ").Value

'added row below
OutRow = OutRow + 1
Next i
End With
'sort output data
Application.StatusBar = "Sorting Output"
With OutSH
'-------------------------- CHANGED ------------------------------
'change this statement
.Range("A6:J" & (OutRow - 1)).Sort _
key1:=.Range("A6"), _
order1:=xlAscending, _
header:=xlYes
'---------------------------- ENd ---------------------------------
End With
Application.StatusBar = False

Sheets("Internal Project Plan").Select

Call Colors

Call Module6.SaveAs
End Sub

Thanks
 
J

Joel

Yes you can have lots of Arrays. I added some code below. The lines I added
have the word "ADDED" as a comment. I don't understand what you are trying
to do. I went back to the spreadsheet you e-mailed me and wasn't able to
understand what you want to do. I wan't sure if you were refering to the top
portion of your code or bottom section of the code where you are copying the
headers. It seems like you want to copy to add two rows of data when B5 is
Yes but not sure whre the data is coming from.

Re-read your instructions and see if you can add more details. Remember I
have you old spreadsheet which will help. You can e-mail me if you want
instead of posting the information.



Dim OutSH As Worksheet, TemplateSH As Worksheet, ce As Variant
Dim OutRow As Long, i As Long
Dim arr As Variant
Dim arr2 As Variant '<= Added
Dim CopyRow As Boolean
Set OutSH = Sheets("Internal Project Plan")
Set TemplateSH = Sheets("Master Template")

'----------------- ADDED ------------------------------------
Dim CriteriaSH As Worksheet
Dim Timeline As Long
Dim Criteria as string
Set CriteriaSH = Sheets("Criteria")

Criteria = CriteriaSH.Range("B5")
Timeline = Ucase(CriteriaSH.Range("B6") )

If Timeline <> 60 And _
Timeline <> 90 And _
Timeline <> 120 Then

MsgBox ("Incorrect TimeLine")
Exit Sub
End If
'----------------- END ------------------------------------


With TemplateSH
For i = 2 To 700
CopyRow = False
For Each ce In CriteriaSH.Range("B15:B80")
If ce = "Yes" Then

'------------------ CHANGED FROM WORKSHEET FUNCTION -------------
Dim C As Variant
Set C = TemplateSH.Rows("1:1").Find( _
what:=ce.Offset(0, -1).Value, _
LookIn:=xlValues, _
lookat:=xlWhole)
If C Is Nothing Then
MsgBox ("Could not find : " & _
ce.Offset(0, -1).Value)
Exit Sub
Else
If .Cells(i, C.Column).Value = "x" Then
CopyRow = True
Exit For
End If
End If
End If
Next ce

If CopyRow = True Then
OutRow = OutSH.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
OutSH.Cells(OutRow, "A").Value = .Cells(i, "A").Value
OutSH.Cells(OutRow, "B").Value = .Cells(i, "D").Value
OutSH.Cells(OutRow, "C").Value = .Cells(i, "P").Value
OutSH.Cells(OutRow, "D").Value = .Cells(i, "E").Value
OutSH.Cells(OutRow, "I").Value = .Cells(i, "BP").Value
OutSH.Cells(OutRow, "J").Value = .Cells(i, "BR").Value
OutSH.Cells(OutRow, "K").Value = .Cells(i, "O").Value
if Criteria = "YES" '<= Added

end if '<= Added
'--------------------------- New Code -----------------------
Select Case Timeline

Case 60
OutSH.Cells(OutRow, "E").Value = _
.Cells(i, "H").Value
Case 90
OutSH.Cells(OutRow, "E").Value = _
.Cells(i, "K").Value
Case 120
OutSH.Cells(OutRow, "E").Value = _
.Cells(i, "N").Value
End Select
End If
'---------------------------End ----------------------------- End If
Next i
End With


'----------------------------------------------------------------
Application.StatusBar = "Transferring Headings"
arr = Array(2, 16, 85, 97, 98, 111, 127, 145, 160, 185, 193, 196, 211,
241, 308, 329, 340, 433, 447, 451, 476, 522, 549, 568, 597)
arr2 = Array(3, 18, 19, 43, 56, 57, 58, 59, 88) '<= Added

'moved outrow to this location and added counter inside loop
OutRow = OutSH.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row
With TemplateSH
For i = LBound(arr) To UBound(arr)

.Cells(arr(i), "A").Copy _
Destination:=OutSH.Cells(OutRow, "A")

'Duplicate of above row, eliminate
'OutSH.Cells(OutRow, "A").Value = .Cells(arr(i), "A").Value

.Cells(arr(i), "D").Copy _
Destination:=OutSH.Cells(OutRow, "B")

'Duplicate of above row, eliminate
'OutSH.Cells(OutRow, "B").Value = .Cells(arr(i), "D").Value

.Cells(arr(i), "J").Copy _
Destination:=OutSH.Cells(OutRow, "C")

'Duplicate of above row, eliminate
'OutSH.Cells(OutRow, "C").Value = .Cells(arr(i), "J").Value

.Cells(arr(i), "E").Copy _
Destination:=OutSH.Cells(OutRow, "D")

'Duplicate of above row, eliminate
'OutSH.Cells(OutRow, "D").Value = .Cells(arr(i), "E").Value


.Cells(arr(i), "BP").Copy _
Destination:=OutSH.Cells(OutRow, "I")

'Duplicate of above row, eliminate
'OutSH.Cells(OutRow, "I").Value = .Cells(arr(i), "BQ").Value

'added row below
OutRow = OutRow + 1
Next i
End With
'sort output data
Application.StatusBar = "Sorting Output"
With OutSH
'-------------------------- CHANGED ------------------------------
'change this statement
.Range("A6:J" & (OutRow - 1)).Sort _
key1:=.Range("A6"), _
order1:=xlAscending, _
header:=xlYes
'---------------------------- ENd ---------------------------------
End With
Application.StatusBar = False

Sheets("Internal Project Plan").Select

Call Colors

Call Module6.SaveAs
End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Code not working, copy in Select Case section not copying over. 10
Can you help me to improve this macro? 5
Is there something faster than select case? 9
separate multiline address into separate columns 3
i'd like some help using an array 5
simple code but it doesn't look like usual vba code 2
Don't understand - Arrays 101 (Help) 5
Loop to copy paste rows base on table arrays 0

Top