Returning cells as a Matrix VBA

Question

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.

Answer 1

The OP has asked for a VBA solution, so this answer may get down-voted!

However, as an alternative (if you have a recent Excel version) perhaps consider a spreadsheet function to do what you want:

In Sheet2, put this formula in a cell:

=LET(rngIn,Sheet1!A1:P10,x,MAX(rngIn)+1,rng,IF(LEN(rngIn)=0,x,rngIn),FILTER(FILTER(rng,INDEX(rng,1,,1)<>x),INDEX(rng,,1,1)<>x))

Which has this result:

The formula essentially just filters out blanks: first by row and then by column. The input range can be any range, as long as the values are evenly spaced, with blank cells in between: so no need for specifying the gaps. This version works for numerical data, but can be modified if different types of data are used.

Using spreadsheet formulas can be a good alternative to VBA as they do not require the use of .xlsm macro-enabled workbooks.

Answer 2

If you dispose of the newer dynamic functions of MS 365 it suffices to enter the following formula in any target range to get a spilling result:

    =LET(data,A1:P10,r,SEQUENCE(4,1,1,3),c,SEQUENCE(1,4,1,5),INDEX(data,r,c))

If you prefer a VBA approach you might use the following procedure; it

• gets the needed data into a 2-dim data field array (see 1.)
• calculates the needed row & column indices via Sequence() (see 2.a)) and
• passes them to the Index() function executing the transformation into a 4x4 matrix (see 2.b)):

Sub transform(rng As Range, _
       Optional ByVal rowOffset As Long = 3, _
       Optional ByVal colOffset As Long = 5)
'Note: assumes 4x4 matrix with start in first row/column element
'1. get data (1-based 2-dim datafield array)
    Dim data: data = rng.Value2           
'2. transform data
    With Application
    'a) define row/column indices to be maintained
        Dim r: r = .Sequence(4, 1, 1, rowOffset) ' vert 1 ..4 ..7 ..10
        Dim c: c = .Sequence(1, 4, 1, colOffset) ' flat Array(1,6,11,16)
    'b) transform data
        data = .Index(data, r, c)        ' reduce to 4x4 matrix
    End With
'3. write data to any target             ' change to your needs
    Sheet2.Range("A1").resize(UBound(data), UBound(data, 2)) =  data    
End Sub

Example call

Sub ExampleCall()
    Dim rng As Range
    Set rng = Sheet1.Range("A1:P10") 
    transform rng       
End Sub

For more backwards compatibility you could replace the sequence function by your own udf

Answer 3

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

Answer 4

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

Answer 5

Copy Gapped Data

• It is written to get the values from your image into an array and the array is then written to another worksheet. Here gap means the number of empty rows or columns in-between.

Option Explicit

Sub CopyGapped()
    
    Const sName As String = "Sheet1"
    
    Const dName As String = "Sheet2"
    Const dfcAddress As String = "A1"
    
    Const rGap As Long = 2
    Const cGap As Long = 4
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code

    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = sws.UsedRange

    Dim srCount As Long: srCount = srg.Rows.Count
    Dim rOff As Long: rOff = rGap + 1
    If srCount < rOff + 1 Then Exit Sub

    Dim scCount As Long: scCount = srg.Columns.Count
    Dim cOff As Long: cOff = cGap + 1
    If scCount < cOff + 1 Then Exit Sub
    
    Dim sData As Variant: sData = srg.Value
    
    Dim drCount As Long: drCount = Int(srCount / rOff) + 1
    Dim dcCount As Long: dcCount = Int(scCount / cOff) + 1
    
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
    
    Dim sr As Long
    Dim sc As Long
    Dim dr As Long
    Dim dc As Long
    
    For sr = 1 To srCount Step rOff
        dr = dr + 1
        dc = 0
        For sc = 1 To scCount Step cOff
            dc = dc + 1
            dData(dr, dc) = sData(sr, sc)
        Next sc
    Next sr
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    With dws.Range(dfcAddress).Resize(, dcCount)
        .Resize(drCount) = dData
        .Resize(dws.Rows.Count - .Row - drCount + 1).Offset(drCount).Clear
    End With
    
End Sub