Adding and Setting Ranges in Excel VBA - excel

Question

I have this sample table.
What I am trying to do is to get all the cell values in all colored cells and transpose them to another worksheet.
I have trouble with the code below to add and set those ranges together so that I can transpose all of them in a ROW in the other worksheet. I have started with the code below
Sub AddRanges()
Dim inRange As Range, inRangeValues() As Variant, outRangeValues() As Variant
Dim finalRow As Long
Dim inRange As Range
Set inRange = Sheet1.Range("A1:A6", "C1:C6", C10:C14) 'I think i got this wrong; Error Type Mismatch
inRangeValues() = inRange.Value 'generate 2d array
outRangeValues = Application.Transpose(inRangeValues)
With Sheet2
finalRow = .Cells(Rows.Count, 1).End(xlUp).Row 'find last row
If inRange.Columns.Count > 1 Then '2d array for output
.Cells(finalRow + 1, 1).Resize(UBound(outRangeValues, 1), UBound(outRangeValues, 2)) = outRangeValues 'Resize according to output array dimensions
Else '1D array for output
.Cells(finalRow + 1, 1).Resize(1, UBound(outRangeValues, 1)) = outRangeValues
End If
End With
End sub
In this example, what is the best approach to combine these ranges so I can transpose them as a ROW? Thanks.

Answer 1

Your code has major problems due to:
Double declaration of inRange
Wrong syntax for Set inRange the entire address needs to be enclosed in a single pair of quotes
Try Set inRange = Range("a1:a6, c1:c6, c10:c14")
Wrong method of reading into an array
When you have a range that consists of multiple areas, you have to convert each area separately.
Then you can create a 1-D array from this depending on the order you wish to have these elements, and write it wherever you want.
For example:
Option Explicit
Sub test()
Dim inRange As Range, inRangeValues As Variant, outRangeValues As Variant
Dim finalRow As Long
Dim I As Long, J As Long, V As Variant, L As Long
Dim lCols As Long
Set inRange = Range("a1:a6, c1:c6, c10:c14")
ReDim inRangeValues(1 To inRange.Areas.Count)
For I = 1 To inRange.Areas.Count
inRangeValues(I) = inRange.Areas(I)
Next I
'how many columns?
lCols = 0
For I = 1 To UBound(inRangeValues, 1)
lCols = lCols + UBound(inRangeValues(I), 1)
Next I
ReDim outRangeValues(1 To lCols)
L = 0
For I = 1 To UBound(inRangeValues, 1)
For J = 1 To UBound(inRangeValues(I), 1)
L = L + 1
outRangeValues(L) = inRangeValues(I)(J, 1)
Next J
Next I
Stop
' enter some code to write the results where you want
' below is just throwaway for proof of concept
Range("f20").Resize(columnsize:=UBound(outRangeValues)).Value = outRangeValues
End Sub
Given your input, the above code would create output like:

Answer 2

You are correct that your code is wrong where you highlight. Try a union. From there, it should be pretty basic to just loop through your range and put them wherever you want in the Sheet2 spreadsheet. See if the below does what you need.
Sub AddRanges()
Dim inRange As Range, acell As Range, aCounter As Long
Const startAddress As String = "A1"
Set inRange = Union(Sheet1.Range("A1:A6"), Sheet1.Range("C1:C6"), Sheet1.Range("C10:C14"))
For Each acell In inRange.Cells
If Not IsEmpty(acell) Then
finalRow = sheet2.Cells(Rows.Count, 1).End(xlUp).Row + 1 'find last row
sheet2.Cells(finalRow, 1).Value = acell.Value
End If
Next acell
End Sub

Answer 3

Check it out.
Sub RngAreaTransps()
Dim RangeArea As Range, LstRw As Long
Dim sh As Worksheet, ws As Worksheet
Dim col As Long, InRange As Range
Set sh = Sheets(1)
Set ws = Sheets(2)
LstRw = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
With sh
Set InRange = .Range("A1:A6, C1:C6, C10:C14")
For Each RangeArea In InRange.Areas
With ws
col = .Cells(LstRw, .Columns.Count).End(xlToLeft).Column
If col <> 1 Then col = col + 1
RangeArea.SpecialCells(xlCellTypeConstants).Copy
.Cells(LstRw, col).PasteSpecial Transpose:=True
End With
Next RangeArea
End With
Application.CutCopyMode = False
End Sub