importeren gegevens met variabele bestandsnaam

[jcb1958]

Beste mensen,

Ik gebruik onderstaande code om een gegevens te importeren.

Mijn vraag: Soms is de bestandsnaam Portefeuille.xlsx soms ook Portefeuille-1.xlsx. Nu krijg ik foutmelding : Fout 9 tijdens uitvoering: Het subscript valt buiten het bereik en moet ik het bestand hernoemen naar Portefeuille.xlsx.

Hoe kan ik er voor zorgen dat wanneer de bestandsnaam Portefeuille-1 (of wat anders).xlsx ook wordt geaccepteerd door de macro?

GR

Jacob

Sub import()
    Windows("[COLOR="#FF0000"]Portefeuille.xlsx[/COLOR]").Activate
    Range("B4:b12").Select
    Selection.Copy
    Windows("Map1_test.xlsm").Activate
    With Sheets("Blad1")
        .Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
        For i = 1 To .UsedRange.Rows.Count
            If Cells(i, 1) = "" Then
                .Cells(i, 1) = Format(Date, "dd-mmm")
                .Cells(i, 2) = Format(Date, "ww")
                .Cells(i, 3) = Format(Date, "mm")
            End If
        Next i
    End With
End Sub

 

[HSV]

Zo te zien aan je code heb je beide bestanden openstaan.
Sluit de portefeuille bestanden en kies het bestand met onderstaande code.

Verander het rode gedeelte in waar de portefeuille bestanden zich bevinden.

Sub import()
Application.ScreenUpdating = False
  With Application.FileDialog(msoFileDialogOpen)
    .InitialFileName = [COLOR=#ff0000]"C:\Users\JCB1958\documents\Map1"[/COLOR]
    .FilterIndex = 2
    .Show
    .Execute
  End With
If ActiveWorkbook.Name <> ThisWorkbook.Name Then
  With ActiveWorkbook
     ThisWorkbook.Sheets("Blad1").Cells(Rows.Count, 4).End(xlUp).Offset(1).Resize(9) = Sheets(1).Range("b4:b12").Value
     .Close 0
  End With
 Sheets("blad1").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(9, 3) = Array(Format(Date, "dd-mmm"), DatePart("ww", Date, 2, 2), Format(Date, "mm"))
End If
End Sub

 

[jcb1958]

Nee dat is het niet HSV
.
portefeuille bestand download ik via internet en importeer het naar Map1_test.xlsm.

 

[HSV]

Wat een lap tekst hé als je mijn berichten quote.

Sub import()
Application.ScreenUpdating = False
 Windows(2).Activate
     With ThisWorkbook.Sheets("Blad1")
       .Cells(Rows.Count, 4).End(xlUp).Offset(1).Resize(9) = Sheets(1).Range("b4:b12").Value
       .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(9, 3) = Array(Format(Date, "dd-mmm"), DatePart("ww", Date, 2, 2), Format(Date, "mm"))
     End With
  ThisWorkbook.Activate
End Sub

Gelieve dus niet quoten.

 

[jcb1958]

sorry zal het niet meer doen

maar heb je een andere oplossing misschien?

 

[jcb1958]

Beste cow18


werkt niet goed helaas

Wat ik eigenlijk zoek is iets dat Portefeuille.xlsx vervangt voor Portefeuille*.xlsx. Net zoals in Windows bijvoorbeeld (*.*) . Hoop dat het duidelijk is.

 

[jcb1958]

ik kreeg < de rest > bij jouw

IK ga er ff mee verder thx anyway

 

[HSV]

De code uit #4 voldoet ook niet ?

 

[jcb1958]

Nee helaas niet

Zal het proberen iets duidelijker uit te leggen:

• Portefeuille wordt rechtstreeks geopend vanuit de internet pagina (Firefox)
• daarna open ik de map beleggen in Excel (staat ergens op mijn PC)
• hier heb ik dan een knop waar de code is aangekoppeld

Het gebeurt weleens dat Portefeuille geopend wordt als Portefeuille-1 of Portefeuille -2. Wanneer dit gebeurd moet ik eerst de uit internet geopende map Portefeuille-1 opslaan als Portefeuille en dan kan ik weer verder. Vervolgens moet ik de map C:\Users\Gebruiker\AppData\Local\Temp leegmaken, zodat het de volgende dag weer goed gaat.

Wat ik dus zoek is iets net zoals in Windows kan om in de code Portefeuille te hernoemen naar Portefeuille* of zoiets

is dat mogelijk?

 

[HSV]

Windows(2) idem dito.
Daarmee maakt het niet uit welke naam het bestand heeft.

Windows(1) = Thisworkbook, en Windows(2) het andere bestand.

 

[jcb1958]

Ik heb #8 geprobeerd maar helaas wordt er niets geïmporteerd. Krijg ook geen foutmelding.

Wat is er nog fout?

Dit is wat ik nu heb:

Sub ZoekPortefeuille()
    Dim wb
    
    
    For i = 1 To Windows.Count
        If LCase(Windows(i).Caption) Like "portefeuille*.xls*" Then Set wb = Windows(i): Exit For    'zoek een window die begint met Portefeuille (hoofdlettergevoelig)
    Next
    If VarType(wb) = vbEmpty Then MsgBox "foutje": Exit Sub
    
    wb.Activate
    
    Range("B4:c8").Select
    Selection.Copy
    
    Windows("Beleggen 2019.xlsm").Activate
    With Sheets("Data")
        .Range("E" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
        For i = 1 To .UsedRange.Rows.Count
            If Cells(i, 1) = "" Then
                If sRow = 0 Then sRow = i - 1
                .Cells(i, 1).NumberFormat = "dd-mmm-yyy"
                .Cells(i, 1) = Date
            End If
        Next i
        .Range("B" & sRow & ":C" & .UsedRange.Rows.Count).FillDown
    End With
End Sub

 

[jcb1958]

Beste Cow18,

IK heb het voor elkaar. Heb nog een paar dingetjes gewijzigd en uiteindelijk werkt het

Heel veel dank voor de support.

Gr

Jacob

Dit is wat ik heb nu:

Sub import(control As IRibbonControl)
    
    
    ActiveWorkbook.Worksheets("Data").ListObjects("Tabel1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Data").ListObjects("Tabel1").Sort.SortFields.Add _
        Key:=Range("Tabel1[[#All],[Datum]]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Data").ListObjects("Tabel1").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    
    
    Dim sRow As Long


    Dim wb
    
    
    For i = 1 To Windows.Count
        If LCase(Windows(i).Caption) Like "portefeuille*.xls*" Then Set wb = Windows(i): Exit For    'zoek een window die begint met Portefeuille (hoofdlettergevoelig)
    Next
    If VarType(wb) = vbEmpty Then MsgBox "foutje": Exit Sub
    
    wb.Activate
       
    Range("B4:c8").Select
    Selection.Copy
    
    Windows("Beleggen 2019.xlsm").Activate
    With Sheets("Data")
        .Range("E" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
        For i = 1 To .UsedRange.Rows.Count
            If Cells(i, 1) = "" Then
                If sRow = 0 Then sRow = i - 1
                .Cells(i, 1).NumberFormat = "dd-mmm-yyy"
                .Cells(i, 1) = Date
            End If
        Next i
        .Range("B" & sRow & ":C" & .UsedRange.Rows.Count).FillDown
    End With
End Sub

 

[HSV]

Uitkijken met welk bestand je op voorgrond hebt.
Hang de code aan de knop en voer het van daaruit.

Je bestand "Portefeuille-1" of hoe het bestand ook mag heten wordt herbenoemd naar "Portefeuille".

Sub import()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 Workbooks(Windows(2).Caption).SaveAs Workbooks(Windows(2).Caption).Path & "\Portefeuille", 51
     With ThisWorkbook.Sheets("Blad1")
       .Cells(Rows.Count, 4).End(xlUp).Offset(1).Resize(9) =Workbooks("Portefeuille.xlsx").Sheets(1).Range("b4:b12").Value
       .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(9, 3) = Array(Format(Date, "dd-mmm"), DatePart("ww", Date, 2, 2), Format(Date, "mm"))
     End With
End Sub