Nested Import Loops

[u473]

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.

 

[Jim Rech]

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
|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.

 

[u473]

Thank you for response. I inserted your suggestion on the Loop Until.
I do not get any error message, but my destination worksheet does not
get populated at all.
I will run it in Debug Mode again to see where I went wrong.
Thank you for your help,
Celeste

 

[Jim Rech]

I will run it in Debug Mode

I did run your code, btw, and got data in the destination sheet. Debugging
step by step should find the answer though.

--
Jim
| Thank you for response. I inserted your suggestion on the Loop Until.
| I do not get any error message, but my destination worksheet does not
| get populated at all.
| I will run it in Debug Mode again to see where I went wrong.
| Thank you for your help,
| Celeste