This code throws a type mismatch error on the second loop through at
. I have no idea what's causing this. Any ideas?
Thank you for your time!
Code:
[COLOR=#FF0000]Do While Selection.Value <> ""[/COLOR]
Thank you for your time!
Code:
Sub OpenProjectCopyPasteData2()
Dim PrjApp As MSProject.Application
Dim aProg As MSProject.Project
Dim PrjRange As Range
Dim PrjFullName As String
Dim t As Task
Dim rng As Range
Dim rng1 As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim MyCell As String
Dim Lastrow As Long
Set ws1 = Worksheets("MS Project Milestones")
Set rng1 = ws1.Range("A:F")
Set ws2 = Worksheets("Active NRE Projects")
Set PrjApp = New MSProject.Application
'Clear current contents of Project Data tab
rng1.ClearContents
'For Each MyCell In PrjRange
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Open MS Project file
ws2.Activate
ActiveSheet.Range("C2").Select
[COLOR=#ff0000]Do While Selection.Value <> ""[/COLOR]
MyCell = Selection.Value
PrjFullName = MyCell
PrjApp.FileOpenEx PrjFullName
Set aProg = PrjApp.ActiveProject
' show all tasks
'OutlineShowAllTasks
ws1.Activate
'Copy the project columns and paste into Excel
SelectTaskColumn Column:="Name"
EditCopy
Set ws1 = Worksheets("MS Project Milestones")
Set rng = ws1.Range("A" & Cells(Rows.Count, "A").End(xlUp).Row + 1)
rng.PasteSpecial xlPasteValues
rng.PasteSpecial xlPasteFormats
SelectTaskColumn Column:="Resource Names"
EditCopy
Set rng = ws1.Range("B" & Cells(Rows.Count, "B").End(xlUp).Row + 1)
rng.PasteSpecial xlPasteValues
rng.PasteSpecial xlPasteFormats
SelectTaskColumn Column:="Finish"
EditCopy
Set rng = ws1.Range("F" & Cells(Rows.Count, "F").End(xlUp).Row + 1)
rng.PasteSpecial xlPasteValues
rng.PasteSpecial xlPasteFormats
SelectTaskColumn Column:="Text1"
EditCopy
Set rng = ws1.Range("C" & Cells(Rows.Count, "C").End(xlUp).Row + 1)
rng.PasteSpecial xlPasteValues
rng.PasteSpecial xlPasteFormats
SelectTaskColumn Column:="Text2"
EditCopy
Set rng = ws1.Range("D" & Cells(Rows.Count, "D").End(xlUp).Row + 1)
rng.PasteSpecial xlPasteValues
rng.PasteSpecial xlPasteFormats
With Sheets("MS Project Milestones")
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
Lastrow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
Lastrow = 1
End If
End With
With Sheets("MS Project Milestones")
.Range("A" & (Lastrow + 1)).Value = "X"
.Range("B" & (Lastrow + 1)).Value = "X"
.Range("C" & (Lastrow + 1)).Value = "X"
.Range("D" & (Lastrow + 1)).Value = "X"
.Range("F" & (Lastrow + 1)).Value = "X"
End With
' reset settings of Excel and MS-Project
Application.DisplayAlerts = True
Application.ScreenUpdating = True
PrjApp.ScreenUpdating = True
PrjApp.DisplayAlerts = True
'PrjApp.FileClose False
PrjApp.Quit pjDoNotSave
Set PrjApp = Nothing
Selection.Offset(1, 0).Select
Loop
End Sub