Selectie uit een matrix

[meijj01]

Beste forumleden,

met behulp van Excel wil ik uit een matrix (toegevoegd in de bijlage) een importbestand maken waarbij alleen de waarden terugkomen als er wat ingevuld staat.
De import ziet er zo uit:

400050 5930670 -8040
411107 5920332 40
411107 5920333 50
411108 5920332 80

Eerste kolom moet dus kolom A weergeven als kolom D E F G H > 0
Tweede kolom geeft altijd rij 4 terug en de waarde van de kolom waar de waarde groter is dan 0

Hopelijk kunnen jullie mij helpen met om dit op te lossen en is mijn vraag duidelijk genoeg?

vr. gr. Jan

 

[Thoralf]

Is dit wat je bedoelt?

 

[Warme bakkertje]

Test deze eens.

Sub tst()
    Dim result, startrow As Long
    startrow = 1
    With Sheets("Blad1")
    sn = .Cells(1, 2).CurrentRegion.Value
    ReDim result(1 To UBound(sn) * 5, 1 To 3)
    For i = 5 To UBound(sn)
        If sn(i, 3) <> 0 Then
            For j = 4 To 8
                If sn(i, j) <> vbNullstring Then
                    result(startrow, 1) = sn(i, 1)
                    result(startrow, 2) = sn(4, j)
                    result(startrow, 3) = sn(i, j)
                    startrow = startrow + 1
                End If
            Next
        End If
    Next
    .Cells(1, 10).Resize(UBound(result), 3) = result
    End With
End Sub

 

[meijj01]

Is dit wat je bedoelt?

Bedoeling is juist dat ik uit de Matrix de simpele 3 kolommetjes terugkrijg . Totaal bestand heeft ongeveer 500 kolommen en 700 regels in de tabel en die wil ik terugbrengen naar de simpele 3 kolommen..

 

[cow18]

die macro van Warm bakkertje zal wel het gevraagde doen, maar je zal enkel nog het bereik waar hij naar toe schrijft moeten aanpassen, best een ander blad aangezien je zo'n grote bron hebt. Eigenlijk had ik liever een dictionary gebruikt gezien ipv. die array, het werkt sneller.

 

[meijj01]

Maar dan heb ik enkel de waarde en nog niet de code uit de eerste kolom en de code uit rij 4 ervoor waar het bedrag bij hoort toch?

 

[VenA]

Het werkt altijd makkelijker als je met aaneengesloten bereiken werkt dus zonder lege regels. Je kan dan Currentregion gebruiken om een array te vullen.
Zo lukt het ook wel maar is wat omslachtiger.

Sub VenA()
With Sheets(1)
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row
    lc = Cells(1, Columns.Count).End(xlToLeft).Column
    ar = .[A4].Resize(lr, lc)
    ReDim ar1(.[D4].Resize(lr, lc).SpecialCells(2).Count + 1, 1 To 3)
    For j = 2 To UBound(ar)
        For jj = 4 To UBound(ar, 2)
            If ar(j, jj) <> "" Then
                ar1(t, 1) = ar(j, 1)
                ar1(t, 2) = ar(1, jj)
                ar1(t, 3) = ar(j, jj)
                t = t + 1
            End If
        Next jj
    Next j
    .[k18].Resize(UBound(ar1) + 1, 3) = ar1
End With
End Sub

 

[snb]

Overeenkomstig Cow18's gedachte:

Sub M_snb()
  sn = Blad1.Cells(1).CurrentRegion
  Blad1.Cells(1).CurrentRegion.Columns(4).Resize(, 5).SpecialCells(-4123, 1).Value = Blad1.Cells(1).CurrentRegion.Columns(4).Resize(, 5).SpecialCells(-4123, 1).Value
  
  With CreateObject("scripting.dictionary")
    For Each it In Blad1.Cells(1).CurrentRegion.Columns(4).Resize(, 5).SpecialCells(2, 1)
      If it.Row > 4 Then .Item(.Count) = Array(sn(it.Row, 1), sn(4, it.Column), it)
    Next
  
    Blad1.Cells(50, 1).Resize(.Count, 3) = Application.Index(.items, 0, 0)
  End With
End Sub

 

[meijj01]

Dit werkt prima! Aangezien ik geen specialist ben, alleen nog de vraag welk stukje ik in de formule moet aanpassen om naar 500 kolommen en 700 rijen te komen

 

[Warme bakkertje]

Het aantal regels speelt geen rol, voor de kolommen bij Resize het getal 5 uitbreiden naar aantal gebruikte kolommen (zonder de drie basiskolommen)

 

[snb]

Ik moest nog wel eerst de formule in c6 doortrekken naar c5 om een aaneengesloten gebied (currentregion) te krijgen.

 

[Warme bakkertje]

Omdat die regel leeg was had ik 'm gewoon verwijderd.

 

[meijj01]

Ik krijg nu met onderstaande code tm rij 90 de resultaten:

Sub Jan()
With Sheets(1)
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
lc = Cells(1, Columns.Count).End(xlToLeft).Column
ar = .[A4].Resize(lr, lc)
ReDim ar1(.[D4].Resize(lr, lc).SpecialCells(2).Count + 1, 1 To 3)
For j = 2 To UBound(ar)
For jj = 4 To UBound(ar, 2)
If ar(j, jj) <> "" Then
ar1(t, 1) = ar(j, 1)
ar1(t, 2) = ar(1, jj)
ar1(t, 3) = ar(j, jj)
t = t + 1
End If
Next jj
Next j
.[k400].Resize(UBound(ar1) + 1, 3) = ar1
End With

End Sub

Ben nog wel een aantal rijen meer nodig, maar dan krijg ik een foutmelding en geeft de foutopsporing aan dat het hier mis gaat: ar1(t, 1) = ar(j, 1)

Zit er toch nog een foutje in of doe ik iets niet goed?

 

[Warme bakkertje]

Sub M_snb()
  sn = Blad1.Cells(1).CurrentRegion
  Blad1.Cells(1).CurrentRegion.Columns(4).Resize(, 497).SpecialCells(-4123, 1).Value = Blad1.Cells(1).CurrentRegion.Columns(4).Resize(, 5).SpecialCells(-4123, 1).Value
  
  With CreateObject("scripting.dictionary")
    For Each it In Blad1.Cells(1).CurrentRegion.Columns(4).Resize(, 497).SpecialCells(2, 1)
      If it.Row > 4 Then .Item(.Count) = Array(sn(it.Row, 1), sn(4, it.Column), it)
    Next
  
    Blad2.Cells(1).Resize(.Count, 3) = Application.Index(.items, 0, 0)
  End With
End Sub

 

[snb]

Zoek in de hulpfunktie van de VBEditor op wat currentregion betekent.
Pas je bestand (niet je code) daarop aan.

 

[meijj01]

Ik heb alle lege kolommen en rijen verwijderd. Dat bedoelde je met het aanpassen van het bestand neem ik aan? Helaas nog steeds in foutmelding

 

[Warme bakkertje]

Sub M_snb()
  sn = Blad1.Cells(1).CurrentRegion: sp = Blad1.Cells(1).CurrentRegion.Columns.Count - 3
  On Error Resume Next
  Blad1.Cells(1).CurrentRegion.Columns(4).Resize(, sp).SpecialCells(-4123, 1).Value = Blad1.Cells(1).CurrentRegion.Columns(4).Resize(, sp).SpecialCells(-4123, 1).Value
  On Error GoTo 0
  With CreateObject("scripting.dictionary")
    For Each it In Blad1.Cells(1).CurrentRegion.Columns(4).Resize(, sp).SpecialCells(2, 1)
      If it.Row > 4 Then .Item(.Count) = Array(sn(it.Row, 1), sn(4, it.Column), it)
    Next
    Blad2.Cells(1, 1).Resize(.Count, 3) = Application.Index(.items, 0, 0)
  End With
End Sub

 

[snb]

In het bestand dat je hier plaatste was 1 waarde het resultaat van een formule.
Met regel 2 moest de formulewaarde eerst omgezet worden in een vaste waarde.
Als je andere bestand in het waardengebied geen formules bevat heb je die regel niet nodig:

Sub M_snb()
  sn = Blad1.Cells(1).CurrentRegion
 
  With CreateObject("scripting.dictionary")
    For Each it In Blad1.Cells(1).CurrentRegion.offset(4,3).SpecialCells(2, 1)
      .Item(.Count) = Array(sn(it.Row, 1), sn(4, it.Column), it)
    Next

    Blad2.Cells(1, 1).Resize(.Count, 3) = Application.Index(.items, 0, 0)
  End With
End Sub

 

[Warme bakkertje]

Staan er geen formules tussen krijg je foutmelding, wij weten het hoe en waarom.
Daarom leek het mij veiliger om het zo op te lossen. Staan er nog formules tussen worden ze omgezet, in het andere geval gaat de code gewoon voort.

 

[snb]

Volledig mee eens.