D
DanielleVBANewbie
Hi friends,
The code below is to copy information that matches in one sheet to another
sheet. I am having problems with one area where I need it to look at
criteria of days. Everything is working fine except this:
Select Case Timeline
Case 60
.Cells(arr(i), "H").Copy _
Destination:=OutSH.Cells(OutRow, "E")
Case 90
.Cells(arr(i), "K").Copy _
Destination:=OutSH.Cells(OutRow, "E")
Case 120
.Cells(arr(i), "N").Copy _
Destination:=OutSH.Cells(OutRow, "E")
End Select
If any of you could look at this, I am sure I have just missed fixing
something for it not to pull over, because I don't get a compile error or
anything like that.
Thanks
Entire code:
Private Sub CommandButton1_Click()
Dim OutSH As Worksheet, TemplateSH As Worksheet, ce As Variant
Dim DataCol As Integer, OutRow As Long, i As Long
Dim arr As Variant
Set OutSH = Sheets("Internal Project Plan")
Set TemplateSH = Sheets("Master Template")
Dim CriteriaSH As Worksheet
Dim Timeline As Long
Set CriteriaSH = Sheets("Criteria")
Timeline = CriteriaSH.Range("B5")
If Timeline <> 60 And _
Timeline <> 90 And _
Timeline <> 120 Then
MsgBox ("Incorrect TimeLine")
Exit Sub
End If
For Each ce In Range("B15:B80")
If ce = "Yes" Then
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
DataCol = C.Column
End If
With TemplateSH
For i = 2 To 700
If .Cells(i, DataCol).Value = "x" Then
'check to see if it already exists and
'only proceed if it does not
If WorksheetFunction.CountIf(OutSH.Range("A:A"), _
TemplateSH.Cells(i, 1).Value) = 0 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, "BQ").Value
End If
End If
Next i
End With
End If
Next ce
Application.StatusBar = "Transferring Headings"
arr = Array(2, 15, 77, 87, 88, 117, 134, 149, 172, 179, 182, 197, 227,
294, 315, 326, 418, 432, 436, 461, 507, 534, 553, 582)
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")
.Cells(arr(i), "D").Copy _
Destination:=OutSH.Cells(OutRow, "B")
.Cells(arr(i), "J").Copy _
Destination:=OutSH.Cells(OutRow, "C")
.Cells(arr(i), "E").Copy _
Destination:=OutSH.Cells(OutRow, "D")
Select Case Timeline
Case 60
.Cells(arr(i), "H").Copy _
Destination:=OutSH.Cells(OutRow, "E")
Case 90
.Cells(arr(i), "K").Copy _
Destination:=OutSH.Cells(OutRow, "E")
Case 120
.Cells(arr(i), "N").Copy _
Destination:=OutSH.Cells(OutRow, "E")
End Select
.Cells(arr(i), "BQ").Copy _
Destination:=OutSH.Cells(OutRow, "I")
OutRow = OutRow + 1
Next i
End With
'sort output data
Application.StatusBar = "Sorting Output"
With OutSH
.Range("A6:J" & (OutRow - 1)).Sort _
key1:=.Range("A6"), _
order1:=xlAscending, _
header:=xlYes
End With
Application.StatusBar = False
Sheets("Internal Project Plan").Select
Call Colors
Call Module6.SaveAs
End Sub
The code below is to copy information that matches in one sheet to another
sheet. I am having problems with one area where I need it to look at
criteria of days. Everything is working fine except this:
Select Case Timeline
Case 60
.Cells(arr(i), "H").Copy _
Destination:=OutSH.Cells(OutRow, "E")
Case 90
.Cells(arr(i), "K").Copy _
Destination:=OutSH.Cells(OutRow, "E")
Case 120
.Cells(arr(i), "N").Copy _
Destination:=OutSH.Cells(OutRow, "E")
End Select
If any of you could look at this, I am sure I have just missed fixing
something for it not to pull over, because I don't get a compile error or
anything like that.
Thanks
Entire code:
Private Sub CommandButton1_Click()
Dim OutSH As Worksheet, TemplateSH As Worksheet, ce As Variant
Dim DataCol As Integer, OutRow As Long, i As Long
Dim arr As Variant
Set OutSH = Sheets("Internal Project Plan")
Set TemplateSH = Sheets("Master Template")
Dim CriteriaSH As Worksheet
Dim Timeline As Long
Set CriteriaSH = Sheets("Criteria")
Timeline = CriteriaSH.Range("B5")
If Timeline <> 60 And _
Timeline <> 90 And _
Timeline <> 120 Then
MsgBox ("Incorrect TimeLine")
Exit Sub
End If
For Each ce In Range("B15:B80")
If ce = "Yes" Then
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
DataCol = C.Column
End If
With TemplateSH
For i = 2 To 700
If .Cells(i, DataCol).Value = "x" Then
'check to see if it already exists and
'only proceed if it does not
If WorksheetFunction.CountIf(OutSH.Range("A:A"), _
TemplateSH.Cells(i, 1).Value) = 0 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, "BQ").Value
End If
End If
Next i
End With
End If
Next ce
Application.StatusBar = "Transferring Headings"
arr = Array(2, 15, 77, 87, 88, 117, 134, 149, 172, 179, 182, 197, 227,
294, 315, 326, 418, 432, 436, 461, 507, 534, 553, 582)
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")
.Cells(arr(i), "D").Copy _
Destination:=OutSH.Cells(OutRow, "B")
.Cells(arr(i), "J").Copy _
Destination:=OutSH.Cells(OutRow, "C")
.Cells(arr(i), "E").Copy _
Destination:=OutSH.Cells(OutRow, "D")
Select Case Timeline
Case 60
.Cells(arr(i), "H").Copy _
Destination:=OutSH.Cells(OutRow, "E")
Case 90
.Cells(arr(i), "K").Copy _
Destination:=OutSH.Cells(OutRow, "E")
Case 120
.Cells(arr(i), "N").Copy _
Destination:=OutSH.Cells(OutRow, "E")
End Select
.Cells(arr(i), "BQ").Copy _
Destination:=OutSH.Cells(OutRow, "I")
OutRow = OutRow + 1
Next i
End With
'sort output data
Application.StatusBar = "Sorting Output"
With OutSH
.Range("A6:J" & (OutRow - 1)).Sort _
key1:=.Range("A6"), _
order1:=xlAscending, _
header:=xlYes
End With
Application.StatusBar = False
Sheets("Internal Project Plan").Select
Call Colors
Call Module6.SaveAs
End Sub