Having a few issues....

[cweggleto81]

Hi all,
It's been a while since I did any VBA stuff. I have the code below and it does work, however I want the data to start on Row 4 on the spreadsheet. Currently it only goes for the first available blank line which is no good for the purpose. Any ideas? Any help is appreciated

Sub Macro1()

Dim objFSO As Object, objFolder As Object, objFile As Object
Dim strFolderName As String
Dim wb As Workbook
Dim lngMyRow As Long
Dim FldrPicker As FileDialog

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

With FldrPicker
.Title = "Select Target Charges Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
strFolderName = .SelectedItems(1) & ""
End With

NextCode:
strFolderName = strFolderName
If strFolderName = "" Then GoTo ResetSettings


Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objFolder = objFSO.GetFolder(strFolderName)

For Each objFile In objFolder.Files
If InStr(objFSO.GetExtensionName(objFile.Name), "xls") > 0 Then 'Only interested in Excel files
Set wb = Workbooks.Open(objFolder & "" & objFile.Name)
'Puts the data from the named ranges into the next available row in columns A, B abd C in 'Sheet1'. Change to suit if necessary.
On Error Resume Next 'In case there's no data in 'Sheet1' manually set the variable
lngMyRow = ThisWorkbook.Sheets("Sheet1").Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
If lngMyRow = 0 Then
lngMyRow = 4 'Default initial output row number. Change to suit if necessary
End If
On Error GoTo 0
With ThisWorkbook.Sheets("Sheet1")
.Range("A" & lngMyRow) = wb.Names("ACCNTNAME").RefersToRange
.Range("B" & lngMyRow) = wb.Names("ACCNTNUM").RefersToRange
.Range("C" & lngMyRow) = wb.Names("TOTALCOST").RefersToRange
End With
wb.Close False
End If
Next objFile

Application.ScreenUpdating = True

ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

 

[NdNoviceHlp]

For Each objFile In objFolder.Files
If InStr(objFSO.GetExtensionName(objFile.Name), "xls") > 0 Then 'Only interested in Excel files
Set wb = Workbooks.Open(objFolder & "" & objFile.Name)
'Puts the data from the named ranges into the next available row in columns A, B abd C in 'Sheet1'. Change to suit if necessary.
On Error Resume Next 'In case there's no data in 'Sheet1' manually set the variable
'lngMyRow = ThisWorkbook.Sheets("Sheet1").Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
'If lngMyRow = 0 Then
lngMyRow = 4 'Default initial output row number. Change to suit if necessary
'End If
On Error GoTo 0
With ThisWorkbook.Sheets("Sheet1")
.Range("A" & lngMyRow) = wb.Names("ACCNTNAME").RefersToRange
.Range("B" & lngMyRow) = wb.Names("ACCNTNUM").RefersToRange
.Range("C" & lngMyRow) = wb.Names("TOTALCOST").RefersToRange
End With
wb.Close False
lngMyRow = lngMyRow + 1
End If
Next objFile

HTH. Dave

 

[cweggleto81]

Thankyou, all good.

 

[NdNoviceHlp]

You are welcome. Thanks for posting your outcome. Dave