Ga naar inhoud

Welkom op PC Helpforum!
PC Helpforum helpt GRATIS computergebruikers sinds 2006. Ons team geeft via het forum professioneel antwoord op uw vragen en probeert uw pc problemen zo snel mogelijk op te lossen. Word lid vandaag, plaats je vraag online en het PC Helpforum-team helpt u graag verder!


Dixon

Vanuit tabel meerdere waarden oplijsten

    Aanbevolen berichten

    Beste,

     

     

    Ik heb een bestand met twee tabbladen, nl.:

    1. Gegevens
    2. Lijst

     

    Gegevens

    In het tabblad "Gegevens" staat een tabel / kalender met allerlei gegevens.

    Ik zou via een macro deze tabel moeten kunnen omzetten in een lijst zoals op tabblad "Lijst".

    De weergave zou dus voor elke dag de waarde bij een bepaald nummer moeten weergeven.

     

    Bijkomend probleem:

    De kalender telt nu 10 rijen (nummers) en 15 kolommen (dagen). Ik weet nooit hoe lang de lijst zal zijn en hoe lang de kalender zal zijn.

    D.w.z. dat er volgende keer 15 of 20 rijen (nummers) kunnen staan OF dat er 30 of 31 kolommen (dagen) in kunnen staan.

     

    Ter info:

    Het max. aantal nummers is ongekend (t.e.m. de eerste blanco)

    Het max aantal dagen is 31.

     

    Hoe zou ik dit door een macro kunnen laten transformeren?

     

     

    Hartelijk dank.

     

     

    Dixon

     

    Voorbeeld.xlsx

    aangepast door Dixon

    Deel dit bericht


    Link naar bericht
    Delen op andere sites

  • Topicstarter
  •    9

    Hey JeanPaul28,

     

     

    Dat werkt ongelooflijk goed, maar in de omgekeerde richting.

    De basis is het tabblad gegevens en de output zou de lijst moeten zijn.

     

    Tabblad gegevens is een kalender dat aangeleverd wordt. Ik zou dit in lijst vorm moeten kunnen verwerken.

     

    Bedankt!

     

     

    Dixon

    Deel dit bericht


    Link naar bericht
    Delen op andere sites

    @Dixon,

    Je hebt 10 nummers in kolom A en 15 datums in rij 1
    In blad "Lijst" moeten de datums vertikaal komen in kolom A, en elk nummer moet bij elke datum weergegeven worden, wat wil zeggen dat elke datum vertikaal 10 x moet worden weergegeven. Dat worden dan 15 x 10 = 150 datums. In A2:A11 komt dan 01-09-17, in A12:A21 komt 02-09-17, enz. Programmatisch kopieer je 01-09-17 naar A2:A11, 02-09-17 naar A12:A21, enz.
    De nummers 1 t/m 10 kopieer je naar B2:B11, B12:B21, enz., totaal 15 x.
    De gegevens in de kolommen B t/m P van het blad "Gegevens" moeten in Blad "Lijst" onder elkaar komem in kolom C (vanaf C2). Dat betekent ook weer 15 x kopiëren, waarbij het kolomnr. telkens met 1 en  het rijnr. met 10 moet worden opgehoogd.
    De getallen 10 en 15 van hierboven maak je variabel (je noemt ze bv. a en b, waarbij a kan staan voor het aantal nummers en b voor het aantal datums), zodat ze niet alleen voor de getallen 10 en 15 maar voor elk aantal nummers en elk aantal datums gelden.
    Dat is in het kort het belangrijkste wat programmatisch moet gebeuren.
    Het kost een aantal uren tijd, maar dan heb je ook wat.

     

    Deel dit bericht


    Link naar bericht
    Delen op andere sites

    Er gaat veel tijd verloren met over en weer kopieëren van gegevens, daarom bouw je best je array op in het geheugen en schrijf deze dan in 1X naar je werkblad Lijst.

    Test deze maar eens met een variabel aantal rijen en kolommen.
     

    Sub tst()
        Dim sn, sq, j As Long, i As Long, ii As Long
        't = Timer
        sn = Blad1.Cells(1).CurrentRegion.Value
        ReDim sq(1 To (UBound(sn) * UBound(sn, 2)), 1 To 3)
        j = 1
        
        For i = 2 To UBound(sn, 2)
            For ii = 2 To UBound(sn)
                sq(j, 1) = sn(1, i)
                sq(j, 2) = sn(ii, 1)
                sq(j, 3) = sn(ii, i)
                j = j + 1
            Next
        Next
        
        With Blad2
            .Cells(1).CurrentRegion.Offset(1).ClearContents
            .Cells(2, 1).Resize(UBound(sq), 3) = sq
        End With
        'MsgBox Timer - t
    End Sub

     

    Deel dit bericht


    Link naar bericht
    Delen op andere sites

    • Welkom op PC Helpforum

    • Leden statistieken

      • Aantal leden
        39.285
      • Meeste online
        1.622

      Nieuwste lid
      Henk Bos
      Registratiedatum
    • Gerelateerde inhoud

      • Door bennieboef
        Hallo Allemaal,

        Mijn macro zoekt in een windows map op de volgende manier : "prd." + <cell value> + ".dld"
        Het probleem is dat er niet wordt gezocht in inderliggende bmappen

        Hier de macro :

        Option Explicit

        Sub Find_DLD()
        Dim AckTime As Integer, InfoBox As Object
        Dim iRow As Integer ' ROW COUNTER.
        Dim sSourcePath As String, currentpath As String
        Dim sDestinationPath As String
        Dim sFileType As String
        Dim sFileType1 As String

        Dim bContinue As Boolean

        bContinue = True
        iRow = 2

        ' THE SOURCE AND DESTINATION FOLDER WITH PATH.
        sSourcePath = "S:"
        sFileType = ".dld" ' TRY WITH OTHER FILE TYPES LIKE ".pdf".
        sFileType1 = "prd."


        ' LOOP THROUGH COLUMN "B" TO PICK THE FILES.
        While bContinue

        If Len(Range("E" & CStr(iRow)).Value) = 0 Then ' DO NOTHING IF THE COLUMN IS BLANK.
        Set InfoBox = CreateObject("WScript.Shell")
        AckTime = 1
        Select Case InfoBox.Popup("Klaar.", _
        AckTime, "Hieperdepiep", 0)
        Case 1, -1
        Exit Sub
        End Select
        Else
        ' CHECK IF FILES EXISTS.

        If Len(Dir(sSourcePath & sFileType1 & Range("E" & CStr(iRow)).Value & sFileType)) = 0 Then
        Range("F" & CStr(iRow)).Value = "Geen kantprogramma"
        Range("F" & CStr(iRow)).Font.Bold = True
        Else
        Range("F" & CStr(iRow)).Value = "Kantprogramma bestaat!"
        Range("F" & CStr(iRow)).Font.Bold = False

        End If
        End If
        iRow = iRow + 1 ' INCREMENT ROW COUNTER.
        Wend
        End Sub

        Het zou fantastisch zijn al iemand deze code zo kan aanpassen dat de macro ook in de onderliggende mappen van s:\ gaat zoeken.

        Alvast bedankt voor jullie hulp.
         
        Bijlage :  bestand met macro.
        Controle dxf + kantprogramma.xlsm
      • Door bickyvp
        hallo iedereen,
         
        ik ben bezig voor mijn wergever met een excel van al onze stockproducten en om zo eenvoudig te kunnen zien wat er besteld moet worden.
        dit heb ik reeds gedaan.
         
        nu wil ik dat ik snel kan sorteren op wat er besteld moet worden.  het vak waarin staat dat er besteld moet worden is dmv vba.
        de celgrote is niet overal gelijk omdat dat niet anders kan of niet goed uitkomt.
         
        natuurlijk moet heel de rij juist mee volgen met het sorteren. ik krijg mijn werkbladen maar niet gesorteerd.
        waarbij ik meteen kan zien wat er moet besteld worden.
         
        kan iemand mij hierbij helpen of op weg zetten ?
        (ps: in bijlage vind je de excel, enkel de 3 eerste werkbladen wil ik zo gesorteerd hebben)
         
        alvast heel erg bedankt
        groeten michael
        magazijn vp.xlsm
      • Door t&d
        De code werkte eerst maar nu niet meer?
        Ik denk dat het tussen regel 6 en 19 zit maar ben niet zeker.

        Foutopsporing leid naar commandobutton, maar code is enkel om formulier te open
        Private Sub cmdopen_2_Click() Userform1.Show End Sub  
        Option Explicit Dim blnNew As Boolean Dim Dic As Object, i As Long Private Sub UserForm_Initialize() cmdSave.Enabled = False Frame2.Enabled = False Dim sv, i As Long sv = Sheets(1).Cells(1).CurrentRegion Set Dic = CreateObject("scripting.dictionary") For i = 1 To UBound(sv) If Not Dic.exists(sv(i, 1)) Then Dic.Item(sv(i, 1)) = Array(sv(i, 1), CreateObject("scripting.dictionary"), CreateObject("scripting.dictionary")) Dic(sv(i, 1))(1).Item(sv(i, 2)) = Dic(sv(i, 1))(1).Item(sv(i, 2)) Dic(sv(i, 1))(2).Item(sv(i, 2)) = Array(sv(i, 2), Application.Index(sv, i, Array(1, 3, 6, 7, 10, 11)), i) Next i ComboBox2.List = Dic.keys Dim wb As Workbook: Set wb = ThisWorkbook Dim WS As Worksheet Dim LastRow As Long Dim aCell As Range Set WS = wb.Sheets("Type data") With WS LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row For Each aCell In .Range("C1:C" & LastRow) If aCell.Value <> "" Then Me.TextBox2.AddItem aCell.Value End If Next End With Set WS = wb.Sheets("Type data") With WS LastRow = .Cells(.Rows.Count, "O").End(xlUp).Row For Each aCell In .Range("O1:O" & LastRow) If aCell.Value <> "" Then Me.TextBox5.AddItem aCell.Value End If Next End With End Sub Private Sub cmdClose_Click() If cmdClose.Caption = "Close" Then Unload Me Else cmdClose.Caption = "Close" cmdNew.Enabled = True End If End Sub Private Sub cmdNew_Click() blnNew = True txtklant.Text = "" txttype.Text = "" txtdossier.Text = "" txtdatum.Text = "" txtbestand.Text = "" txtbestemming.Text = "" cmdClose.Caption = "Cancel" cmdNew.Enabled = False cmdSave.Enabled = True Frame2.Enabled = True End Sub Private Sub cmdSave_Click() If Trim(txtklant.Text) = "" Then MsgBox "Enter klant", vbCritical, "Save" txtklant.SetFocus Exit Sub End If Call prSave cmdClose.Caption = "Close" cmdNew.Enabled = True ThisWorkbook.Save End Sub Private Sub prSave() ''''' Save the dms If blnNew = True Then TRows = Worksheets("dms").Range("A1").CurrentRegion.Rows.Count With Worksheets("dms").Range("A1") .Offset(TRows, 0).Value = txtklant.Text .Offset(TRows, 1).Value = txttype.Text .Offset(TRows, 2).Value = txtdossier.Text .Offset(TRows, 3).Value = txtdatum.Text .Offset(TRows, 4).Value = txtbestand.Text .Offset(TRows, 11).Value = txtbestemming.Text End With txtklant.Text = "" txttype.Text = "" txtdossier.Text = "" txtdatum.Text = "" txtbestand.Text = "" txtbestemming.Text = "" Call prComboBoxFill Else For i = 2 To TRows If Trim(Worksheets("dms").Cells(i, 1).Value) = Trim(ComboBox3.Text) Then Worksheets("dms").Cells(i, 1).Value = txtklant.Text Worksheets("dms").Cells(i, 2).Value = txttype.Text Worksheets("dms").Cells(i, 3).Value = txtdossier.Text Worksheets("dms").Cells(i, 4).Value = txtdatum.Text Worksheets("dms").Cells(i, 5).Value = txtbestand.Text Worksheets("dms").Cells(i, 13).Value = txtbestemming.Text txtklant.Text = "" txttype.Text = "" txtdossier.Text = "" txtdatum.Text = "" txtbestand.Text = "" txtbestemming.Text = "" Exit For End If Next i End If blnNew = False If Trim(txtklant.Text) = "" Then cmdSave.Enabled = False Frame2.Enabled = False Else cmdSave.Enabled = True Frame2.Enabled = True End If End Sub Private Sub cmdSearch_Click() Userform1.Show End Sub Private Sub ComboBox2_Change() hsv ComboBox3.List = Dic(ComboBox2.Value)(1).keys ComboBox3.ListIndex = -1 End Sub Private Sub ComboBox3_Change() If ComboBox3.ListIndex > -1 Then For i = 1 To 6 Controls("Textbox" & i).Value = Dic(ComboBox2.Value)(2)(ComboBox3.Value)(1)(i) Next i End If End Sub Private Sub hsv() ComboBox3.ListIndex = -1 For i = 1 To 6 Me.Controls("TextBox" & i).Value = "" Next i End Sub Private Sub Image1_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer) End Sub Private Sub Image2_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer) End Sub  
        test_DMS.xlsm
      • Door K5
        Hier ben ik terug!
        Mijn vorige vraag was om een Macro aan te maken om te printen.
        Ik heb dat excel bestand dus willen overmaken aan die dame, maar ondertussen heeft zij er nog enkele kolommen bij aangemaakt.
        Daarop heb ik haar uitgelegd dat er een knop was voorzien om enkel de kolom met de namen van de leden en de kolom met hun geboortemaand uit te printen.
        Waarop zij fijntjes vroeg of het ook mogelijk was om bij het sorteren via de geboortemaand, iedereen te sorteren volgens "geboortemaand" maar dan ook volgens "geboortedag".
        Het geboortejaar speelt niet direct een rol.
        Zij stuurt namelijk naar alle leden op hun verjaardag een berichtje of een kaartje. Zo kan zij dit beter opvolgen.
      • Door jord
        Beste alle,
        Ik wil graag jullie hulp inschakelen, om onderstaand vba beter te maken. D e bedoeling is dat gegevens van de factuur op een volgend blad geboekt worden. De vba werkt maar niet naar wens. Misschien dat jullie tips hebben.
         
        Sub Knop35_Klikken()
                Dim Datum, factnr, Relatie As String
                Dim totaal As Double
                Datum = Range("O19").Value
                factnr = Range("O20").Value
                Relatie = Range("O21").Value
             
             If Relatie = "" Then
                    MsgBox "Er is geen relatie geselecteerd."
                    Exit Sub
                End If
                If Datum = "" Then
                    MsgBox "Er is geen datum ingevuld."
                    Exit Sub
                End If
                If factnr = "" Then
                    MsgBox "Er is geen factuurnumer ingevuld."
                    Exit Sub
                End If
                With Worksheets("Verkoop").Range("C7:C10000")
                     Set factnr = .Find(Range("O20").Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
                     If Not factnr Is Nothing Then
                        MsgBox "Er is al een factuur met dit nummer aanwezig!"
                        Exit Sub
                      End If
                
        If IsEmpty(Sheets("verkoopfactuur").Range("O20")) Then
        MsgBox "factuurnummer niet ingevuld", vbCritical, "Factuurnummer"
        Exit Sub
        End If
            Dim ws1 As Worksheet, ws2 As Worksheet
            Set ws1 = Sheets("Verkoopfactuur")
            Set ws2 = Sheets("Verkoop")
            DestRow = ws2.Cells(Rows.Count, "A").End(xlUp).Row + 1
            
            ws1.Range("O34:R34").Copy
            ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            ws1.Range("T34").Copy
            ws2.Cells(Rows.Count, 1).End(xlUp).Offset(0, 5).PasteSpecial xlPasteValues
            
            ws1.Range("V34").Copy
            ws2.Cells(Rows.Count, 1).End(xlUp).Offset(0, 7).PasteSpecial xlPasteValues
            
            ws1.Range("X34").Copy
            ws2.Cells(Rows.Count, 1).End(xlUp).Offset(0, 9).PasteSpecial xlPasteValues
            
            ws1.Range("AA34:AC34").Copy
            ws2.Cells(Rows.Count, 1).End(xlUp).Offset(0, 12).PasteSpecial xlPasteValues
        End With
        End Sub
         
        Gr. Jord
    Logo

    OVER ONS

    PC Helpforum helpt GRATIS computergebruikers sinds juli 2006. Ons team geeft via het forum professioneel antwoord op uw vragen en probeert uw pc problemen zo snel mogelijk op te lossen. Word lid vandaag, plaats je vraag online en het PC Helpforum-team helpt u graag verder!

    ×
    ×
    • Nieuwe aanmaken...

    Belangrijke informatie

    We hebben cookies geplaatst op je toestel om deze website voor jou beter te kunnen maken. Je kunt de cookie instellingen aanpassen, anders gaan we er van uit dat het goed is om verder te gaan.