VBA code doesn't work

[Nils_Junker]

Hi everybody,

i got the folloewing code:


Dim WbMain As Workbook
Dim WsFileList As Worksheet
Public Sub subDownloadZipFileFromWeb()
Dim strFileUrl As String
Dim objXmlHttpReq As Object
Dim objStream As Object

Dim rngFileList As Range
Dim strWebFolder As String
Dim rng As Range
Dim strDownloadFolder As String
Dim strUnzippedFolder As String
Dim lngCount As Long
Dim strFilename As String
Dim WsDestination As Worksheet
Dim rngSelected As Range

' On Error GoTo Err_Handler

ActiveWorkbook.Save

Set WbMain = ActiveWorkbook

Set WsFileList = WbMain.Worksheets("SourceFiles")

strWebFolder = "Index of /climate_environment/CDC/observations_germany/climate/10_minutes/air_temperature/recent/"

WsFileList.Activate

If MsgBox("Clear existing data?", vbYesNo, "Question") = vbYes Then
WsFileList.Range("B1:H20000").Cells.ClearContents
End If

WsFileList.Range("B1:H20000").Cells.ClearContents

With WsFileList.Range("A1:F1")
.Value = Array("Filename", "Download Date and Time", "Text File Name", "Rows", "Start", "End")
.Interior.Color = RGB(210, 210, 210)
.Font.Bold = True
.Rows("2:2").Select
ActiveWindow.FreezePanes = True
End With

WsFileList.Range("A1").Select

WsFileList.Cells.EntireColumn.AutoFit

' Get range of files.
On Error Resume Next
Set rngSelected = Application.InputBox( _
Title:="Range Selection", _
Prompt:="Select a rang of files to download.", _
Type:=8)
On Error GoTo 0

If rngSelected Is Nothing Then
MsgBox "Invalid range selected.", vbCritical, "Warning!"
Exit Sub
End If

If (rngSelected.Cells(1, 1).Row < 2) Or _
(rngSelected.Rows.Count > WsFileList.Range("A1").End(xlDown).Row) Or _
(rngSelected.Columns.Count > 1) Or _
(rngSelected.Cells(1, 1).Column <> 1) Then
MsgBox "Invalid range selected.", vbCritical, "Warning!"
Exit Sub
End If

Set rngFileList = rngSelected

strDownloadFolder = ThisWorkbook.Path & "\Downloads\"
Call subDeleteAllFilesInAFolder(strDownloadFolder)

strUnzippedFolder = ThisWorkbook.Path & "\Downloads\Unzipped\"
Call subDeleteAllFilesInAFolder(strUnzippedFolder)

Set WsDestination = Worksheets("ImportedData")

Set objXmlHttpReq = CreateObject("Microsoft.XMLHTTP")

Application.ScreenUpdating = False

For Each rng In rngFileList.Cells

strFilename = rng.Value

strFileUrl = strWebFolder & strFilename

objXmlHttpReq.Open "GET", strFileUrl, False, "username", "password"
objXmlHttpReq.send

If objXmlHttpReq.Status = 200 Then
Set objStream = CreateObject("ADODB.Stream")
objStream.Open
objStream.Type = 1
objStream.Write objXmlHttpReq.responseBody
objStream.SaveToFile strDownloadFolder & "\" & strFilename, 2
objStream.Close
End If

Call subUnzip(strDownloadFolder & "\" & strFilename, strUnzippedFolder)

lngCount = lngCount + 1

Next rng

Set objXmlHttpReq = Nothing

Call subImportDataFromTextFiles(strUnzippedFolder, WsDestination)

Application.ScreenUpdating = True

With WsFileList.Range("A1").CurrentRegion
.RowHeight = 30
End With

MsgBox lngCount & " files have been downloaded.", vbOKOnly, "Confirmation"

Exit_Handler:

Exit Sub

Err_Handler:

MsgBox Err.Number & vbCrLf & _
Err.Description

Resume Exit_Handler

End Sub

Public Sub subUnzip(zipFileName As String, unZipFolderName As String)
' Define Variable Data Types
' Dim zipFileName As String
' Dim unZipFolderName As String
Dim objZipItems As FolderItems
Dim objZipItem As FolderItem

' Early Binding Reference
' Add Tools -> Reference -> "Microsoft Shell Controls & Automation"
Dim wShApp As Shell
Set wShApp = CreateObject("Shell.Application")
Set objZipItems = wShApp.Namespace(zipFileName).items

' Extract: Unzip all Files to Folder
wShApp.Namespace(unZipFolderName).CopyHere objZipItems

End Sub

Public Sub subDeleteAllFilesInAFolder(sFolderPath As String)
Dim oFSO As FileSystemObject

If Right(sFolderPath, 1) = "\" Then
sFolderPath = Left(sFolderPath, Len(sFolderPath) - 1)
End If

'Create FSO Object
Set oFSO = CreateObject("Scripting.FileSystemObject")

'Check Specified Folder exists or not
If oFSO.FolderExists(sFolderPath) Then

oFSO.DeleteFile sFolderPath & "\*.*", True

End If

End Sub

Public Sub subImportDataFromTextFiles(sFolderPath As String, WsDestination As Worksheet)
Dim fsoLibrary As FileSystemObject
Dim fsoFolder As Object
Dim sFileName As Object
Dim s As String
Dim lngRow As Long
Dim arrFileName() As String
Dim dteStart As Date
Dim dteEnd As Date

lngRow = 2

Set fsoLibrary = New FileSystemObject

Set fsoFolder = fsoLibrary.GetFolder(sFolderPath)

'Loop through each file in a folder.
For Each sFileName In fsoFolder.Files

Workbooks.OpenText Filename:=sFileName, DataType:=xlDelimited, Semicolon:=True, DecimalSeparator:=",", ThousandsSeparator:="."

arrFileName = Split(sFileName, "_")

dteStart = DateSerial(Left(arrFileName(4), 4), Mid(arrFileName(4), 5, 2), Right(arrFileName(4), 2))

dteEnd = DateSerial(Left(arrFileName(5), 4), Mid(arrFileName(5), 5, 2), Right(arrFileName(5), 2))

WsFileList.Cells(lngRow, 2).Resize(1, 5).Value = Array(Format(Now(), "dd/mm/yyyy hh:mm:ss"), ActiveWorkbook.Name, ActiveSheet.Range("A1").End(xlDown).Row, dteStart, dteEnd)

ActiveWorkbook.Close

lngRow = lngRow + 1

Next

'Release the memory.
Set fsoLibrary = Nothing
Set fsoFolder = Nothing

WsFileList.Cells.EntireColumn.AutoFit

End Sub


So the code works till i have to fill in a range of files. If i insert for example $A$2:$A$4 then there comes the errowr: Index außerhalb des gültigen Bereichs (Fehler 9)
Also no line will get marked yellow if the error comes up. And the person who did the Code says that it works on his Laptop.
Can it be that i need to change some settings?

 

[davesexcel]

It error usually indicates the code can't find something, do you have the two workbooks, the code is looking for?

Step through the code and see when the error happens.

 

[Nils_Junker]

It error usually indicates the code can't find something, do you have the two workbooks, the code is looking for?

solved the problem othewise but thanks!!!!

 

[Fluff]

Duplicate to: VBA code doesn't work

In future, please do not post the same question multiple times. Per Forum Rules (#12), posts of a duplicate nature will be locked or deleted.

In relation to your question here, I have closed this thread so please continue in the linked thread.