Returning cells as a Matrix VBA-CodePudding

I have a bunch of cells in a sheet that look like this:

Each rows has a gap of 3, and columns a gap of 5.

Id like to extract these values and copy it to some area:

How would I grab each cell and create a matrix like so. Im trying to use a VBA sub() for this, as the initial table size can vary but Im not sure how to do it. Any thoughts appreciated.

CodePudding user response：

For your data...

Sub DeleteEmptyCells()
  Dim rngArea As Range
  Dim rngAreaErg As Range
  
  'determine usedrange of worksheet
  Set rngArea = Sheet1.UsedRange
  
 'identify all empty cells in area
  Set rngAreaErg = rngArea.SpecialCells(xlCellTypeBlanks)
  
  'delete empty cells by killig empty columns
  rngAreaErg.Delete xlShiftToLeft

  'determine alle empty cells, again
  Set rngAreaErg = rngArea.SpecialCells(xlCellTypeBlanks)
  
  'delete empty cells by killing empty rows
  rngAreaErg.Delete xlShiftUp

End Sub

CodePudding user response：

The result go to Sheet2

Sub TransferNotEmptyCells()
  Dim rngArea As Range
  Dim rngCell As Range
  Dim lngRow As Long, lngRowMax As Long, lngCol As Long, lngColMax As Long
  Dim lngRowTarget As Long, lngColTarget As Long
 
 'Clear Target worksheet
  Sheet2.UsedRange.Clear
  'set row/Col to Start-Position
  lngRowTarget = 1
  lngColTarget = 1
    
  With Sheet1
  'determine usedrange in Sheet1
   lngRowMax = .Cells(.Rows.Count, 1).End(xlUp).Row
   lngColMax = .Cells(1, .Columns.Count).End(xlToLeft).Column
   
   'Create two loops to read all filled cells
   For lngRow = 1 To lngRowMax
   
    For lngCol = 1 To lngColMax
    
      If .Cells(lngRow, lngCol).Value <> "" Then
        Sheet2.Cells(lngRowTarget, lngColTarget).Value = .Cells(lngRow, lngCol).Value
        lngColTarget = lngColTarget   1
      End If
    
    Next lngCol
    
    lngColTarget = 1
    
    If .Cells(lngRow, 1).Value <> "" Then
     lngRowTarget = lngRowTarget   1
    End If
   Next lngRow
  
  End With
 
End Sub