VBA code om celinhoud op te halen

[anton44]

In het gedeelte van het onderstaand macro-deel staan een aantal variabelen die ik vanuit cellen van een werkblad (tab) wil ophalen.
Als voorbeeld:
Werkbladnaam = “Dashboard”
In cel A1 de mapnaam : “D:\Downloads\”
In cel A2 de bestandsnaam: “Bank transactieoverzicht*.csv”
In cel A3 de bestandsnaam: “Bank.csv”
In cel A4 "D:\Downloads\Bank.csv" als resultaat van A1&A3

Sub BANK01_Hernoemen()
' Bank downloadbestand hernoemen naar een standaard naam
Application.ScreenUpdating = False
Dim OldName, NewName
OldName = Dir("D:\Downloads\Bank transactieoverzicht*.csv")
If Len(OldName) > 0 Then
OldName = "D:\Downloads\" & OldName: NewName = "D:\Downloads\Bank.csv"
If Len(Dir(NewName)) > 0 Then
Kill NewName
End If
Name OldName As NewName
Else
MsgBox "Bestand is niet gevonden", vbInformation, "Onvindbaar"
GoTo Fout1
End If

Call BANK02_Ophalen 'roept volgende macro aan

Fout1:
' Macro stopt bij "Bestand is niet gevonden".

End Sub

Mijn vraag: Hoe moet ik daarvoor mijn macro aanpassen.
m.vr.gr. Ton

 

[edmoor]

Probeer deze maar eens:

Sub BANK01_Hernoemen()
    ' Bank downloadbestand hernoemen naar een standaard naam
    Dim OldName As String, NewName As String

    OldName = Dir("D:\" & Range("A2"))
    If Len(OldName) > 0 Then
        OldName = Range("A1") & OldName
        NewName = Range("A1") & Range("A3")
        If Len(Dir(NewName)) > 0 Then
            Kill NewName
        End If
        Name OldName As NewName
    Else
        MsgBox "Bestand is niet gevonden", vbInformation, "Onvindbaar"
        Exit Sub
    End If
    
    Call BANK02_Ophalen 'roept volgende macro aan
End Sub

 

[anton44]

Bedankt edmoor en wat een snelle reactie :d
Ik ga dit testen maar ik mis nog de code om het juiste werkblad te activeren waar de cellen A1 enz staan. In het voorbeeld staan die in werkblad "Dashboard" Naast dit tabblad staan er nog een aantal meer.

 

[edmoor]

Ok, inclusief de juiste bladnaam:

Sub BANK01_Hernoemen()
    ' Bank downloadbestand hernoemen naar een standaard naam
    Dim OldName As String, NewName As String

    With Sheets("Dashboard")
        OldName = Dir("D:\" & .Range("A2"))
        If Len(OldName) > 0 Then
            OldName = .Range("A1") & OldName
            NewName = .Range("A1") & .Range("A3")
            If Len(Dir(NewName)) > 0 Then
                Kill NewName
            End If
            Name OldName As NewName
        Else
            MsgBox "Bestand is niet gevonden", vbInformation, "Onvindbaar"
            Exit Sub
        End If
    End With
    
    Call BANK02_Ophalen 'roept volgende macro aan
End Sub

 

[anton44]

Hartelijk dank.
Ik ga dit nu testen en hou je op de hoogte.
m.vr.gr. Ton

 

[anton44]

edmoor,
Je voorstel werkt prima. Bedankt.
Ik ben nog een stap verder willen gaan maar loop vast.

Werkbladnaam = “Dashboard”
In cel A1 de mapnaam : “D:\Downloads\”
In cel A2 de bestandsnaam: “Bank transactieoverzicht*.csv”
In cel A3 de bestandsnaam: “Bank.csv”
In cel A4 "D:\Downloads\Bank.csv" als resultaat van A1&A3
In cel A5 "D:\Downloads\Bank transactieoverzicht*" als resultaat van A1&A2


With Sheets("Dashboard")
OldName = Dir("D:" & .Range("A2"))
als dit de volledige bestandsnaam "D:\Downloads\Bank transactieoverzicht*.csv" is heb ik daarvoor deze waarde in cel A5 staan als samenvoeging van cel A1 en A2. Hiermee veranderd de code in OldName = Dir(.Range("A5")) Dit werkt op deze plaats !!

If Len(OldName) > 0 Then
OldName = .Range("A1") & OldName
NewName = .Range("A1") & .Range("A3")
Als ik deze oplossing ook hier wil toepassen gaat het mis. De volgende code-aanpassing werkt niet.
OldName = .Range("A5")
NewName = .Range("A4")

Wat doe ik hier fout ?

m.vr.gr.
Ton

 

[edmoor]

Kan ik zo niet zien. Plaats je volledige macro en graag binnen Code tags.

 

[anton44]

Werkend
(met juiste tabblad- en celverwijzigingen):
Werkbladnaam = “Variabelen”
In cel D15 de mapnaam : “D:\Downloads\”
In cel E15 de bestandsnaam: “Knab transactieoverzicht*.csv”
In cel G15 de bestandsnaam: “Bank.csv”
In cel H15 "D:\Downloads\Bank transactieoverzicht*" - volledige naam als resultaat van D15 & E15
In cel J15 "D:\Downloads\Bank.csv" - volledige naam als resultaat van D15 & H15

Sub KNAB01_Hernoemen()
' KNAB downloadbestand hernoemen naar een standaard naam
  Application.ScreenUpdating = False 'Voorkomt flikkeren van het beeldscherm
 
  Dim OldName, NewName
  With Sheets("Variabelen")
 '  OldName = Dir("D:\Downloads\Knab transactieoverzicht*.csv")
    OldName = Dir(.Range("H15"))
    If Len(OldName) > 0 Then
       ' OldName = "D:\Downloads\" & OldName
        OldName = .Range("D15") & OldName
       ' NewName = "D:\Downloads\Knab.csv"
        NewName = .Range("D15") & .Range("I15")
        If Len(Dir(NewName)) > 0 Then
         Kill NewName
    End If
        Name OldName As NewName    ' Move and rename file.
    Else
        MsgBox "Bestand is niet gevonden", vbInformation, "Onvindbaar"
        GoTo Fout1
    End If
  End With
    Call KNAB02_Ophalen 'roept volgende macro aan
                  
Fout1:
    ' Macro stopt bij "Bestand is niet gevonden" / Start de volgende sub niet.
    
End Sub

Na aanpassing werkt niet:

Sub KNAB01_Hernoemen()
' KNAB downloadbestand hernoemen naar een standaard naam
  Application.ScreenUpdating = False 'Voorkomt flikkeren van het beeldscherm
 
  Dim OldName, NewName
  With Sheets("Variabelen")
 '  OldName = Dir("D:\Downloads\Knab transactieoverzicht*.csv")
    OldName = Dir(.Range("G15"))
    If Len(OldName) > 0 Then
        [B]OldName = .Range("H15")[/B]
     '       OldName = .Range("D15") & OldName
         [B]NewName = .Range("J15")[/B]
     '       NewName = .Range("D15") & .Range("I15")
        If Len(Dir(NewName)) > 0 Then
         Kill NewName
    End If
        Name OldName As NewName    ' Move and rename file.
    Else
        MsgBox "Bestand is niet gevonden", vbInformation, "Onvindbaar"
        GoTo Fout1
    End If
  End With
    Call KNAB02_Ophalen 'roept volgende macro aan
                  
Fout1:
    ' Macro stopt bij "Bestand is niet gevonden" / Start de volgende sub niet.
    
End Sub

 

[Ginger]

OFF TOPIC...

Wat is jou motivatie om over te stappen naar Windows 10 als je huidig OS goed functioneert ?

"Ezelsbruggetje"... als je "jou" door "uw" kan vervangen, wordt het "jouw"...

 

[anton44]

OFF TOPIC...



"Ezelsbruggetje"... als je "jou" door "uw" kan vervangen, wordt het "jouw"...

Met vriendelijke dank
Heb al gewijzigd.

 

[anton44]

Terug naar Topic
De reden dat de eerder genoemde code niet werkt komt door het gebruik van wildcards in declareren van Namen.
Ik heb inmiddels wel een oplossing gevonden hoe het wel kan maar loop tegen een ander probleem aan waardoor mijn "project" (toepassingsafhankelijke gegevens in macro's naar een dashboard brengen)nog niet werkend is.
Als ik in de volgende deelcode de uitgeschreven bestandsnaam vervang door een NAAM (NewName = Range("A9") wordt bij het runnen het bestand niet gevonden.
De MsgBox ervoor laat zien dat de NewName wel de juiste bestandsnaam heeft.
Heb ik iets verkeerd gedaan?, is er een oplossing ?

  Sub Ophalen()
    ActiveWorkbook.Worksheets("Import").Select
    MsgBox [B]Newname[/B]
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;[B]D:\Downloads\Bank transactieoverzicht.csv[/B]", _
        Destination:=Range("$A$8"))
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 1252
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = True
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = True
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 4, 1, 1, 1, 1, 1, 4, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    End Sub

 

[edmoor]

Als Range("A9") dit bevat:
D:\Downloads\Bank transactieoverzicht.csv

dan zou het zo moeten werken:
Connection:="TEXT;" & Range("A9"), _

Of:
Connection:="TEXT;" & NewName, _

 

[anton44]

Edmoor,
Bedankt. het werkt !!! :thumb:

Hierbij de code om de bestandsnaam op te halen en te laden in cel A1 van werkblad "Variabelen"
In A9 kort ik de naam van A1 in ( deel(A1; enz) die vervolgens de naam NewName gedeclareerd krijgt.
Eenzelfde aanpak heb ik gedaan voor de naam van de downloadmap en de bestandsextensie (.csv).
Mocht je nog ergens valkuilen zien, dan graag terugkoppeling.
m.vr.gr. Ton

Sub Converteren()
  Sheets("Variabelen").Select
  With Sheets("Variabelen")
Dim oWbk As Workbook
Dim sFil As String
Dim sPath As String
Dim lRij As Long
    lRij = 1
    sPath = .Range("A7") ' i.p.v. "D:\downloads"
    ChDir sPath
    sFil = Dir("*" & Range("A6")) ' i.p.v. sFil = Dir("*.csv")
    Do While sFil <> ""
        Range("A" & lRij) = sFil
        lRij = lRij + 1
        sFil = Dir
    Loop
 End With

'Sub Hernoemen()
  Dim Oldname, Newname, NewName2
  Sheets("Variabelen").Select
    Oldname = Range("A8")  ' i.p.v. OldName = Dir("D:\Downloads\Bank transactieoverzicht*.csv"
    If Len(Oldname) > 0 Then
        Oldname = Range("A8")
        Newname = Range("A9")
        MsgBox Newname
    If Len(Dir(Newname)) > 0 Then
    End If
        Name Oldname As Newname    ' Move and rename file.
    Else
        MsgBox "Bestand is niet gevonden", vbInformation, "Onvindbaar"
        GoTo Fout1
    End If

Fout1:
    ' Macro stopt bij "Bestand is niet gevonden" / Start de volgende sub niet.

 'Sub Ophalen()
    ActiveWorkbook.Worksheets("Import").Select
    With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & Newname, _
        Destination:=Range("$A$8"))
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 1252
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = True
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = True
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 4, 1, 1, 1, 1, 1, 4, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    
    Kill Newname
    
  '  Call Bank03_Kolomschikking 'roept volgende macro aan

    End Sub

 

[edmoor]

Kan het zo niet testen uiteraard, maar ik zou het wel iets anders schrijven voor de leesbaarheid. Daarnaast heb je dingen als sheets.select en chdir niet nodig. Onderstaande is dus niet getest dus het zou goed kunnen dat het niet exact werkt zoals je wilt.

Sub Converteren()
    Dim oWbk As Workbook
    Dim sFil As String
    Dim sPath As String
    Dim lRij As Long
    Dim Oldname As String
    Dim Newname As String
    Dim NewName2 As String
    
    With Sheets("Variabelen")
        lRij = 1
        sFil = Dir(.Range("A7") & "\*" & .Range("A6")) 'i.p.v. sFil = Dir("*.csv")
        Do While sFil <> ""
            .Range("A" & lRij) = sFil
            lRij = lRij + 1
            sFil = Dir
        Loop
    End With
    
    With Sheets("Variabelen")
        Oldname = .Range("A8")              'i.p.v. OldName = Dir("D:\Downloads\Bank transactieoverzicht*.csv"
        If Len(Oldname) > 0 Then
            Newname = .Range("A9")
            MsgBox Newname
            If Len(Dir(Newname)) > 0 Then
                Name Oldname As Newname     'Move and rename file.
            End If
        Else
            'Macro stopt bij "Bestand is niet gevonden" / Start de volgende sub niet.
            MsgBox "Bestand is niet gevonden", vbInformation, "Onvindbaar"
            Exit Sub
        End If
    End With

    With Sheets("Import").QueryTables.Add(Connection:="TEXT;" & Newname, _
        Destination:=.Range("$A$8"))
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 1252
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = True
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = True
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 4, 1, 1, 1, 1, 1, 4, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    
    Kill Newname
    
  '  Call Bank03_Kolomschikking 'roept volgende macro aan
End Sub

 

[anton44]

Alweer dank.
Ik ga het onderzoeken en hou je op de hoogte.

 

[anton44]

Getest en krijg een foutmelding
Fout 424 - Object vereist

 

[edmoor]

Waarom staat daar With Sheets("Variabelen").Select ?
Zo staat dat niet in mijn voorbeeld.

 

[anton44]

Oeps, een typefout van mij

Het renamen werkt nu prima, maar het ophalen geeft toch een foutmelding.
Door het terugwijzigen naar :
ActiveWorkbook.Worksheets("Import").Select
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & Newname, _
Destination:=Range("$A$8"))

enz.

werkt het wel zoals bedoeld.

 

[edmoor]

Zoals ik al zei kan ik dat hier zo niet testen.

 

[anton44]

Zoals ik al zei kan ik dat hier zo niet testen.

edmoor,
Ik vind het prima zo.
Vwb VBA ben ik een leek en probeer met puzzelstukjes en deeloplossingen iets te bouwen waar ik plezier aan heb.

Met enorme dank wil ik deze thread voorlopig als "opgelost" beschouwen.