Fyi, it helps to provide some clue about what the problem is.

As far as I can see this macro should run okay unless some data files have
nothing in column H. It assumes there is at least one item. Change the
Loop to this to address that issue:

Loop Until ActiveCell.Row = LastRow

--
Jim
"u473" wrote in message
...
|I looked at others codes but I am still running in circles for
| probably some obvious error.
| From one Folder, many Workbooks, single Worksheet, same format,
| append All non blank rows in a single worksheet.
|
| Public Sub Import()
| Dim fso As Object
| Dim Source As Object ' Folder
| Dim WB As Object ' Source Workbook
| Dim WS As Object ' Destination Workbook
| Dim LastRow As String
| Dim R1 As Integer ' Destination WorkSheet Start Row
|
| R1 = 3
| Set fso = CreateObject("Scripting.FileSystemObject")
| Set Source = fso.GetFolder("C:\USB20FD (E)\TestFolder1")
|
| Set WS = ThisWorkbook.Sheets(1)
| For Each WB In Source.FILES
| If LCase(Right(WB.Name, 4)) = ".xls" Then
| Workbooks.Open Filename:=WB.Path
| Cells.UnMerge
| LastRow = Range("H65335").End(xlUp).Row
| Range("H1").Select ' Test Column to decide whether to Import
| or not
| Do
| If IsNumeric(Left(ActiveCell, 2)) = True Or ActiveCell = " -
| " Then
| WS.Cells(R1, 1).Value = Range("C7") '
| Project Name
| WS.Cells(R1, 2).Value = ActiveCell ' Code
| WS.Cells(R1, 3).Value = ActiveCell.Offset(0, 5) ' Date
| WS.Cells(R1, 4).Value = ActiveCell.Offset(0, 6) ' Cost
| Else
| GoTo LINE1
| End If
| R1 = R1 + 1
| LINE1:
| ActiveCell.Offset(1, 0).Select
| Loop Until ActiveCell.Row = LastRow
| Workbooks(WB.Name).Close False
| End If
| Next WB
| End Sub
|
| I am still a Newbie and I need to pass this hurdle. Help appreciated,
| Celeste.