Omdanne matrix til tabel

prøv denne makro. Kør den og marker hele matrixen når du bliver spurgt

Sub liste()
Dim rnga As Range
Dim rngb As Range
Dim rngc As Range
Dim listen()
Dim y As Long, x As Long

y = 0
Set rnga = Application.InputBox(prompt:="hvilket område skal listes?", Type:=8)
Set rngb = rnga.Offset(1, 1).Resize(rnga.Rows.Count - 1, rnga.Columns.Count - 1)
x = Application.WorksheetFunction.CountA(rngb)
ReDim listen(x, 3)
For Each c In rngb
  y = y + 1
  listen(y, 1) = Cells(c.Row, rnga.Column).Value
  listen(y, 2) = Cells(rnga.Row, c.Column).Value
  listen(y, 3) = c.Value
Next
Set rngc = Application.InputBox(prompt:="Hvortil ?", Type:=8)

rngc.Resize(x, 3) = listen

End Sub

Glemte lige at skrive at øverst i modulet skal der stå
Option Base 1
ellers får du kun to kolonner

her er en lidt forbedret version, hvor det ikke er nødvendigt med option base 1 og den tager højde for at der kan være tomme celler.

Sub Matrix2List()
  Dim rgMatrixTotal As Range
  Dim rgMatrixData As Range
  Dim rgMatrixOutput As Range
  Dim rgCell As Range
  Dim vaList()
  Dim y As Long
  Dim x As Long

  y = 0

  Set rgMatrixTotal = Application.InputBox(prompt:="Hvilket område skal listes?", Type:=8)
  With rgMatrixTotal
      Set rgMatrixData = .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
      x = rgMatrixData.Cells.Count
      ReDim vaList(0 To x, 0 To 2)
      For Each rgCell In rgMatrixData
        vaList(y, 0) = Cells(rgCell.Row, .Column).Value
        vaList(y, 1) = Cells(.Row, rgCell.Column).Value
        vaList(y, 2) = rgCell.Value
        y = y + 1
      Next
  End With
  Set rgMatrixOutput = Application.InputBox(prompt:="Indsættes hvor ?", Type:=8)

  rgMatrixOutput.Resize(x, 3) = vaList

End Sub

Wow den var sej. Hvis du har mulighed for at bytte om så datoen kommer før projektnummeret samt at den udover blanke heller ikke tager værdien 0 med, så køber jeg den sgu.

Sub Matrix2List()
  Dim rgMatrixTotal As Range
  Dim rgMatrixData As Range
  Dim rgMatrixOutput As Range
  Dim rgCell As Range
  Dim vaList()
  Dim y As Long
  Dim x As Long

  y = 0

  Set rgMatrixTotal = Application.InputBox(prompt:="Hvilket område skal listes?", Type:=8)
  With rgMatrixTotal
      Set rgMatrixData = .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
      x = rgMatrixData.Cells.Count
      ReDim vaList(0 To x, 0 To 2)
      For Each rgCell In rgMatrixData
        If Not CSng(rgCell) = 0 Then
        vaList(y, 1) = Cells(rgCell.Row, .Column).Value
        vaList(y, 0) = Cells(.Row, rgCell.Column).Value
        vaList(y, 2) = rgCell.Value
        y = y + 1
        End If
      Next
  End With
  Set rgMatrixOutput = Application.InputBox(prompt:="Indsættes hvor ?", Type:=8)

  rgMatrixOutput.Resize(x, 3) = vaList

End Sub

Det funker 100% perfekt. Det er alle tiders. Måske jeg skulle sætte mig lidt mere ind i det der VBA, det ser ud til at sparke røv. Hvis man vel og mærke kan bruge det. Send mig et svar så lukker vi den sag.

ok :-)