kathyb0527
08-06-2010, 10:57 AM
I wrote the following code in 2003. It takes data from worksheets in a specific folder, gets rid of duplicates using advanced filter, then pastes them in another sheet. It worked for months, but now that my company has (finally!) upgraded to 2007, it stops at the Paste Special line giving the error application defined or object defined error. Any suggestions?
Dim wsDest As Worksheet
Dim stFullName As String, stShortName As String
Dim wbSourcefile As Workbook
Dim oFSO As Object
Dim Folder As Object
Dim Files As Object
Dim file As Object
Dim fldr
Application.ScreenUpdating = False
Set wsDest = ActiveSheet
wsDest.Range("B1:J1").Clear
'get file
Set oFSO = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
Set Folder = oFSO.GetFolder(.SelectedItems(1))
End With
For Each file In Folder.Files
Workbooks.Open Filename:=file.Path
'consolidate data and paste into worksheet
Set wbSourcefile = ActiveWorkbook
Set rData = wbSourcefile.Sheets(1).Range("C2:C" & Range("C" & Rows.Count).End(xlUp).Row)
With wbSourcefile.Sheets(1)
.Range("E2").Value = "Calc. Conc. Mean"
.Range("E3").Value = ">0"
End With
With rData
.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("E2:E3"), Unique:=True
.Copy
End With
wsDest.Cells(2, Columns.Count).End(xlToLeft).Offset(-1, 1).PasteSpecial
'reset header row
wbSourcefile.Sheets(1).Range("A1").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=True, OtherChar:= _
":", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
wsDest.Cells.Replace What:="Calc. Conc. Mean", Replacement:=wbSourcefile.Sheets(1).Range("B1").Value, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
ActiveWorkbook.Close savechanges:=False
Next file
Set rXtra = wsDest.Range("A" & Range("A" & Rows.Count).End(xlUp).Row).Offset(1, 1)
rXtra.Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Clear
Set oFSO = Nothing
Application.ScreenUpdating = True
End Sub
Dim wsDest As Worksheet
Dim stFullName As String, stShortName As String
Dim wbSourcefile As Workbook
Dim oFSO As Object
Dim Folder As Object
Dim Files As Object
Dim file As Object
Dim fldr
Application.ScreenUpdating = False
Set wsDest = ActiveSheet
wsDest.Range("B1:J1").Clear
'get file
Set oFSO = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
Set Folder = oFSO.GetFolder(.SelectedItems(1))
End With
For Each file In Folder.Files
Workbooks.Open Filename:=file.Path
'consolidate data and paste into worksheet
Set wbSourcefile = ActiveWorkbook
Set rData = wbSourcefile.Sheets(1).Range("C2:C" & Range("C" & Rows.Count).End(xlUp).Row)
With wbSourcefile.Sheets(1)
.Range("E2").Value = "Calc. Conc. Mean"
.Range("E3").Value = ">0"
End With
With rData
.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("E2:E3"), Unique:=True
.Copy
End With
wsDest.Cells(2, Columns.Count).End(xlToLeft).Offset(-1, 1).PasteSpecial
'reset header row
wbSourcefile.Sheets(1).Range("A1").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=True, OtherChar:= _
":", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
wsDest.Cells.Replace What:="Calc. Conc. Mean", Replacement:=wbSourcefile.Sheets(1).Range("B1").Value, LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
ActiveWorkbook.Close savechanges:=False
Next file
Set rXtra = wsDest.Range("A" & Range("A" & Rows.Count).End(xlUp).Row).Offset(1, 1)
rXtra.Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Clear
Set oFSO = Nothing
Application.ScreenUpdating = True
End Sub