I wrote a subroutine to copy different columns from one worksheet and paste to another worksheet. Although the procedure works as expected, every time I execute the procedure I get the message "Runtime Error: 1004". Can anybody help identify the problem that is causing the runtime error in the code below? Thank you very much in advance.
the picture shows the problem and the last one shows what i want to get
when there is "Call listAllFiles" the procedure works badly and when it is not it works fine (good)
when there is "Call listAllFiles", the procedure works badly, and when it is not, everything is fine (good)
the picture shows the problem and the last one shows what i want to get
when there is "Call listAllFiles" the procedure works badly and when it is not it works fine (good)
when there is "Call listAllFiles", the procedure works badly, and when it is not, everything is fine (good)
VBA Code:
Option Explicit
Dim sheet As Worksheet
Sub listAllFiles()
Sheets("ŚT").Select
Arkusz1_ST.Range("A6:J6").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
ActiveCell.Offset(0, 0).Select
Dim Get_Path As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show <> 0 Then
Get_Path = .SelectedItems(1)
End If
Worksheets("ŚT").Cells(2, 3).Value = Get_Path & "\"
End With
Dim objFSO As Scripting.FileSystemObject
Dim objFolder As Scripting.Folder
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(Sheets("ŚT").Range("Get_Path").Value)
Call GetFileDetails(objFolder)
End Sub
Function GetFileDetails(objFolder As Scripting.Folder)
Dim objFile As Scripting.File
Dim nextRow As Long
Dim objSubFolder As Scripting.Folder
nextRow = Cells(rows.Count, 1).End(xlUp).row + 1
On Error Resume Next
For Each objFile In objFolder.Files
Cells(nextRow, 1) = objFile.Name
Cells(nextRow, 2) = objFile.Path
Cells(nextRow, 3) = objFile.Type
Cells(nextRow, 4) = "=VLOOKUP(RC[-2],metadaneexport1!R3C2:R34932C7,2,0)"
Cells(nextRow, 4).NumberFormat = "m/d/yyyy h:mm"
Cells(nextRow, 5) = "=VLOOKUP(RC[-3],metadaneexport1!R3C2:R34932C7,3,0)"
Cells(nextRow, 5).NumberFormat = "m/d/yyyy h:mm"
Cells(nextRow, 6) = "=VLOOKUP(RC[-4],metadaneexport1!R3C2:R34932C7,4,0)"
Cells(nextRow, 6).NumberFormat = "m/d/yyyy h:mm"
Cells(nextRow, 7) = "=VLOOKUP(RC[-5],metadaneexport1!R3C2:R34932C7,5,0)"
Cells(nextRow, 7).NumberFormat = "m/d/yyyy h:mm"
Cells(nextRow, 8) = "=VLOOKUP(RC[-6],metadaneexport1!R3C2:R34932C7,6,0)"
Cells(nextRow, 8).NumberFormat = "m/d/yyyy h:mm"
ActiveSheet.Hyperlinks.Add Cells(nextRow, 9), objFile.Path, TextToDisplay:=objFile.Name
Cells(nextRow, 10) = "=HYPERLINK(SUBSTITUTE(RC[-8],""\""&RC[-9],""""))"
nextRow = nextRow + 1
Next
For Each objSubFolder In objFolder.SubFolders
Call GetFileDetails(objSubFolder)
Next
Sheets("ŚT").Select
Arkusz1_ST.Range("D6:H6").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End Function
Sub komendyCall()
Application.ScreenUpdating = False
USkorosztu:
For Each sheet In Application.Worksheets
If sheet.Name = "ŚT" Or sheet.Name = "metadaneexport1" Or sheet.Name = "" Then
If Application.Sheets.Count > 2 Then
Sheets("ŚT").Select
ActiveSheet.Move Before:=Sheets(1)
' Arkusz2.Visible = True
Sheets("metadaneexport1").Visible = True
Sheets("metadaneexport1").Select
ActiveSheet.Move Before:=Sheets(2)
Sheets("metadaneexport1").Visible = False
End If
Else
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets(3).Activate
Sheets(3).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End If
Next sheet
Dim row, row1, row2 As Long
Call listAllFiles
Proces2:
Sheets("ŚT").Select
'Dim row As String
Dim zakres As String
Range("A5").Select
row1 = Selection.End(xlDown).row
Range("D5").Select
row2 = Selection.End(xlDown).row
zakres = "" & "A5:A" & row1 & ",D5:H" & row2 & ""
Range(zakres).Select
End SubAttachments
Last edited by a moderator:
