VBA code om celinhoud op te halen

anton44 · 15 mei 2016

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 · 15 mei 2016

Probeer deze maar eens:

Code:

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 · 15 mei 2016

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 · 15 mei 2016

Ok, inclusief de juiste bladnaam:

Code:

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 · 15 mei 2016

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

anton44 · 15 mei 2016

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 · 15 mei 2016

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

anton44 · 15 mei 2016

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

Code:

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:

Code:

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 · 15 mei 2016

OFF TOPIC...

anton44 zei:
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 · 15 mei 2016

Ginger zei:
OFF TOPIC...

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

Met vriendelijke dank

Heb al gewijzigd.

anton44 · 17 mei 2016

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 ?

Code:

  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 · 17 mei 2016

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 · 17 mei 2016

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

Code:

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 · 17 mei 2016

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.

Code:

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 · 17 mei 2016

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

anton44 · 17 mei 2016

Getest en krijg een foutmelding
Fout 424 - Object vereist

edmoor · 17 mei 2016

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

anton44 · 17 mei 2016

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 · 17 mei 2016

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

anton44 · 17 mei 2016

edmoor zei:
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.

VBA code om celinhoud op te halen

Verenigingslid

Inventaris

Verenigingslid

Inventaris

Verenigingslid

Verenigingslid

Inventaris

Verenigingslid

Terugkerende gebruiker

Verenigingslid

Verenigingslid

Inventaris

Verenigingslid

Inventaris

Verenigingslid

Verenigingslid

Inventaris

Verenigingslid

Inventaris

Verenigingslid

Wij waarderen jouw privacy