• 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 klaarzetten voor import

Status
Niet open voor verdere reacties.
H

Henk05

Gebruiker
Lid geworden
7 jan 2010
Berichten
72
Goedendag,

Graag wil ik verschillende data per dag klaar zetten voor een import.
Zoals in de bijlage (hopelijk) zichtbaar is is het aantal keren per dag dat er data gegenereerd is verschillend. Zo zal er dus voor de maandag 4x data weggeschreven worden en voor de zaterdag en zondag geen data. De zaterdag en zondag hoeven in dit geval geen dataregels weggeschreven te worden. Dit kan wel elke dag anders zijn.

In de bijlage zal de data weggeschreven moeten gaan worden naar een format zoals weergegeven is onder de kop uitwerking.

Hoe kan ik dit het beste doen via een macro?

Mocht het niet duidelijk zijn dan hoor ik het graag!

Dank alvast.

Bekijk bijlage vb Uren.xlsx
 
Er zijn diverse mogelijkheden om dit met een macro te doen.

bv
Code: 
Sub VenA()
  ar = Cells(1).CurrentRegion
  Set d = CreateObject("scripting.Dictionary")
    For j = 3 To UBound(ar)
      For jj = 3 To UBound(ar, 2)
        If ar(j, jj) <> "" Then d.Item(ar(j, 1) & "|" & ar(j, 2) & "|" & ar(j, jj)) = ""
      Next jj
    Next j
    Cells(14, 6).Resize(d.Count) = Application.Transpose(d.keys)
    Cells(14, 6).Resize(d.Count).TextToColumns , 1, , , , , , , True, "|"
End Sub
 
Nog even de blauwe coderegel toevoegen en het lijkt op voorbeeld.
Code: 
Cells(14, 6).Resize(d.Count) = Application.Transpose(d.keys)
    Cells(14, 6).Resize(d.Count).TextToColumns , 1, , , , , , , True, "|"
[COLOR=#0000ff]    Cells(14, 6).CurrentRegion.Columns(2).TextToColumns Range("G14"), 1, , , , , , , , , Array(1, 4)[/COLOR]
 
Dank, ziet er goed uit.
Alleen wordt de data vanaf kolom F (de 5e kolom) weergegeven. Als ik voor een andere kolom kies dan wordt de data van de datum 2x weergegeven. 1x op de nieuwe nieuwe plek en 1x in kolom G.
Op de nieuwe plek wordt de datum op de Amerikaanse manier neergezet (MM-DD-JJ) en in kolom G op de juiste manier.

Is dit nog op te lossen?

Dank alvast.
 
Zonder de aanvulling van @HSV, die beter opgelet heeft qua datumnotatie.

Code: 
If ar(j, jj) <> "" Then d.Item(ar(j, 1) & "|" & Format(ar(j, 2), "mm-dd-yyyy") & "|" & ar(j, jj)) = ""

Of de verwijzing naar Range("G14") weglaten/aanpassen.
 
Dank, zo bedoelde ik het!

Is het ook nog mogelijk om meerdere formulieren op 1 tabblad te verwerken en de data in een ander tabblad te zetten?
Ik heb een voorbeeld toegevoegd zoals het zou moeten worden. De data zal dan moeten komen te staan in het tabblad Uitwerking

Ook zullen er meer of minder formulieren in blad1 kunnen staan.

Bekijk bijlage vb Uren.xlsx
 
Waarom een .xlsx? Hieinr staat geen code. Het blad 'Uitwerking' is leeg. Waar en wat moet daar komen te staan?
 
Laatst bewerkt:
het zal dan een XLSM worden inderdaad.
In het tabblad Uitwerking zullen dan de velden
MwCode - Datum - Code komen te staan.

Is dit mogelijk? En dan het liefst de data op het tabblad Uitwerking onder elkaar.

Alvast bedankt!

Bekijk bijlage vb Uren.xlsx
 
Code: 
ar = Sheets("blad1").UsedRange
  Set d = CreateObject("scripting.Dictionary")
    For j = 3 To UBound(ar)
      For jj = 3 To UBound(ar, 2)
         If ar(j, 1) <> "MwCode" And ar(j, jj) <> "" Then d.Item(ar(j, 1) & "|" & Format(ar(j, 2), "mm-dd-yyyy") & "|" & ar(j, jj)) = ""
      Next jj
    Next j
    Sheets("uitwerking").Cells(1, 1).Resize(d.Count) = Application.Transpose(d.keys)
   Sheets("uitwerking").Cells(1, 1).Resize(d.Count).TextToColumns , 1, , , , , , , True, "|"
 
't is weer een .xlsx! Je verwacht dus van de helpers dat de geplaatste code en de aanpassingen eerst weer in dit draadje opgezocht worden en deze code vervolgens in het bestand gezet wordt?

@HSV Cells(1,1) = Cells(1);) en is niet de oplossing voor de aanvullende vraag. Een extra lusje er omheen zal het wel doen maar als het al te veel moeite is voor de TS om een bestand te plaatsen met de eerder aangeleverde code dan haak ik een beetje af.
 
Laatst bewerkt:
Je meent het dat cells(1,1) ook als cells(1) geschreven kan worden (wat ik al niet leer vandaag). :p:p:p

Geen extra lus nodig hoor, alles staat netjes onder elkaar in het ander blad.
Jij haakt niet zo snel af, je toetsenbord is alleen wat sneller dan je oplossing.
 

Bijlagen

  • vb Uren.xlsb
    15,9 KB · Weergaven: 44
Dank dank dank! Ziet er heel mooi uit.

Is het ook nog mogelijk om het via een macro te verkrijgen zoals in de bijlage?
Met de kolom aantal erbij en de code vanaf de kolomkoppen?

Mocht hierover nog vragen zijn dan hoor ik ze graag.

Dank alvast!


Bekijk bijlage vb Uren.xlsb
 
Code: 
If ar(j, 1) <> "MwCode" And ar(j, jj) <> "" Then d.Item(ar(j, 1) & "|" & Format(ar(j, 2), "mm-dd-yyyy") & "|" [COLOR="#FF0000"]& ar(2, jj) & "|" &[/COLOR] ar(j, jj)) = ""
 
Misschien is het goed dat je zelf even een poging doet om de code te begrijpen en deze aan te passen. Iets met ar(j,1) <> ""
 
is ook weer zo, dank voor de rest van de hulp! Misschien kan ik jullie hulp nog goed gebruiken, zal nog wel meer vragen hebben :)

If ar(j, 1) <> "" And ar(j, 1) <> "MwCode" And ar(j, jj) <> "" Then d.Item(ar(j, 1) & "|" & Format(ar(j, 2), "mm-dd-yyyy") & "|" & ar(2, jj) & "|" & ar(j, jj)) = ""
 
Ben er de hele dag mee bezig geweest maar kom er niet uit :-(

Als ik nu de macro uitwerking draai dan komt er geen dat voor de kolom code te staan. Ook mis ik de gegevens van de kolom Totaal, dat is niet erg maar ik vind het wel vreemd.
Wat doe ik toch verkeerd?:shocked:

Bekijk bijlage vb Uren.xlsm

Dank alvast!
 
Code: 
Sub Uitwerking()
ar = Sheets("Urenbriefje").UsedRange
  Set d = CreateObject("scripting.Dictionary")
    For j = 7 To UBound(ar)
      For jj =[COLOR=#ff0000] 3[/COLOR] To UBound(ar, 2)
         If ar(j, 1) <> "" And ar(j, 1) <> "MwCode" And ar(j, jj) <> "" Then d.Item(ar(j, 1) & "|" & Format(ar(j, 2), "mm-dd-yyyy") & "|" & [COLOR=#ff0000]ar(6, jj)[/COLOR] & "|" & ar(j, jj)) = ""
      Next jj
    Next j
    Sheets("Uitwerking").Cells(2, 1).Resize(d.Count) = Application.Transpose(d.keys)
   Sheets("Uitwerking").Cells(2, 1).Resize(d.Count).TextToColumns , 1, , , , , , , True, "|"
End Sub
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan