• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Data ophalen uit ander bestand

Status
Niet open voor verdere reacties.

maomanna

Gebruiker
Lid geworden
20 feb 2014
Berichten
234
Hallo,

ik heb een ruwe datadump, waaruit ik informatie obv voorwaarden wil kopieren.
Elke voorwaarde moet in zijn eigen tabblad komen.

De filter is obv de divisie en traject naam.

De meeste voorbeelden hebben een push functie, maar omdat de datadump elke keer overschreven wordt, ben ik opzoek naar een pull functie.

Of werkt het pull principe hetzelfde als de pushfunctie?

Hieronder iig twee voorbeeld bestandjes.
Datadump heeft alleen ruwe data en kan per dag worden overschreven, vandaar dat een functie daar niet in kan.

Als de gebruiker "Rapportage.xlsx" opent, en op de knop haal info op klikt, zou datadump geopend moeten worden en de rijen obv van divisie en trajectnaam naar het daarvoor bedoelde tabblad.

Bekijk bijlage datadump.xlsx
Bekijk bijlage rapportage.xlsx
 
Laatst bewerkt:
Met beide bestanden in dezelfde map.

Code:
Sub VenA()
With GetObject(ThisWorkbook.Path & "\datadump.xlsx")
  For Each sh In ThisWorkbook.Sheets
    If sh.Name <> "Start" Then
      With .Sheets(1).Cells(1).CurrentRegion
        .AutoFilter 12, sh.Name
        .Offset(1).Copy sh.Cells(Rows.Count, 1).End(xlUp).Offset(1)
      End With
    End If
  Next sh
  .Close 0
End With
End Sub
 
Geniaal! werkt opzich prima.
Maar als ik een tweede voorwaarde wil nemen, die in kolom 11 staat?
Dat mag vast in de code staan.

Dus als Traject naam = ww then copy
if traject naam = VV then nothing?
 
in je code is opgenomen dat als kolom 12 (divisies) is gelijk aan de naam van het tabblad, dat hij dan de informatie moet kopieren.
Nu moet hij dit alleen doen, als in kolom 11 "ww" staat. Alle andere waarden (in voorbeeld alleen "ww" gebruikt) moeten niet worden gekopieerd.

Edit:
opgelost met het volgende.

Code:
Sub VenA()
With GetObject(ThisWorkbook.Path & "\datadump.xlsx")
  For Each sh In ThisWorkbook.Sheets
    If sh.Name <> "Start" Then
    With .Sheets(1).Cells(1).CurrentRegion
        .AutoFilter 11, "WW"
        .AutoFilter 12, sh.Name
        .Offset(1).Copy sh.Cells(Rows.Count, 1).End(xlUp).Offset(1)
      End With
    End If
  Next sh
  .Close 0
End With
End Sub

Nu vult hij hem aan, wat moet ik doen, om de regels 3 t/m XXXX te verwijderen en de copy uit te voeren?
in regel 1 komt andere info, regel 2 de titels.
 
Laatst bewerkt:
Als ik het goed begrijp

Code:
sh.cells(1).currentregion.offset(2).clearcontents
 
Het werkt allemaal super goed.

Nu kom ik tot mijn spijt er alleen achter dat de namen van tabbladen max 31 karakters kunnen hebben en dat ":" er niet in mag.

Heb de filter aangepast met een wildcard en de tabbladen genoemd naar iets wat in de divisienaam voor komt.

Code:
Sub VenA()
With GetObject("ThisWorkbook.Path & "\datadump.xlsx")
  For Each sh In ThisWorkbook.Sheets
    If sh.Name <> "Start" Then
    With .Sheets(1).Cells(1).CurrentRegion
        .AutoFilter 11, "WW"
        .AutoFilter 12, "*" & sh.Name & "*"
        sh.Cells(1).CurrentRegion.Offset(2).ClearContents
        .Offset(1).Copy sh.Cells(Rows.Count, 1).End(xlUp).Offset(1)
      End With
    End If
  Next sh
  .Close 0
End With
End Sub

Omdat ik al eerder een vba code had gekregen voor een array om een selectie te kopieren, dacht ik die simpel te kopieren.

Dat werkt dus niet zo.

Met
Code:
Sub VenA()
Dim j As Long

With GetObject("With GetObject(ThisWorkbook.Path & "\datadump.xlsx")")
  For Each sh In ThisWorkbook.Sheets
    For j = .Columns(1).SpecialCells(2).Count To 2 Step -1
    If sh.Name <> "Start" Then
      With .Sheets(1).Cells(1).CurrentRegion
        .AutoFilter 11, "WW"
        .AutoFilter 12, "*" & sh.Name & "*"
        sh.Cells(1).CurrentRegion.Offset(2).ClearContents
        .Offset(1).Copy sh.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 7) = Array(.Cells(j, 1), .Cells(j, 2), .Cells(j, 3), .Cells(j, 6), .Cells(j, 7), .Cells(j, 8), .Cells(j, 14)
      End With
    End If
      Next j
  Next sh
  .Close 0
End With
End Sub

werkt dus niet zo als verwacht.
 
Laatst bewerkt:
Ik begrijp het probleem niet en de extra lus al helemaal niet. Plaats representatieve voorbeelden
 
De code kopieert de hele rij die in de autofilter staat. Alle cellen daarvan.
Nu wil ik niet alle cellen, maar een selectie hiervan, bijv. kolom 1,2,3,5,6,7,12,14 kopieren.

in tab 01. test wat de bedoeling is. De onderste rij op het blad is wat nodig is.
Bekijk bijlage rapportage.xlsx
 
Code:
Sub VenA_hsv()
With GetObject(ThisWorkbook.Path & "\datadump.xlsx")
  For Each sh In ThisWorkbook.Sheets
    If sh.Name <> "Start" Then
    With .Sheets(1).Cells(1).CurrentRegion
    Set Rng = Union(.Columns(1).Resize(, 3), .Columns(5).Resize(, 3), .Columns(12), .Columns(14))
        .AutoFilter 11, "WW"
        .AutoFilter 12, "*" & sh.Name & "*"
        sh.Cells(1).CurrentRegion.Offset(2).ClearContents
        Rng.Offset(1).Copy sh.Cells(Rows.Count, 1).End(xlUp).Offset(1)
      End With
    End If
  Next sh
  .Close 0
End With
End Sub
 
Ik dacht eigenlijk aan het beetje husselen van de kolommen. Is en meer code en langzamer maar waarschijnlijk iets beter leesbaar:d

Code:
Sub VenA()
With GetObject(ThisWorkbook.Path & "\datadump.xlsx")
  With .Sheets(1)
    .Columns(11).Cut
    .Columns(15).Insert
    .Range("D:D,H:J,L:L").Delete
  End With
  For Each sh In ThisWorkbook.Sheets
    If sh.Name <> "Start" Then
      With .Sheets(1).Cells(1).CurrentRegion
        .AutoFilter 7, "*" & sh.Name & "*"
        .AutoFilter 9, "WW"
        .Offset(1).Resize(, 8).Copy sh.Cells(Rows.Count, 1).End(xlUp).Offset(1)
      End With
    End If
  Next sh
  .Close 0
End With
End Sub
 
de aanvulling op de code door HSV is precies wat ik bedoel.

Omdat nog meer aan de datadump gekoppeld is, zou door het husselen die data ook corrupt worden.

iig is de vraag hiermee opgelost!

Grote dank voor de hulp!
 
Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan