How to copy Excel values across? - excel

Question

I need to copy the data in table 1 to a new sheet and format it like
on table 2.
I am using below function which does half of the job.
Function csvRange(myRange As Range)
Dim csvRangeOutput
Dim entry as variant
For Each entry In myRange
If Not IsEmpty(entry.Value) Then
csvRangeOutput = csvRangeOutput & entry.Value & ","
End If
Next
csvRange = Left(csvRangeOutput, Len(csvRangeOutput) - 1)
End Function

Answer 1

Join Data
JoinData is the recommended solution with some 'error handling'.
JoinDataShort is the same without any error handling.
Adjust the values in the constants section before using them.
Both of the mentioned procedures use the remaining three procedures.
The Code
Option Explicit
Sub joinData()
' Source
Const srcName As String = "Sheet1"
Const srcCols As String = "A:B"
Const srcLastRowCol As Long = 2
Const srcFirstRow As Long = 1
' Destination
Const dstName As String = "Sheet1"
Const dstFirst As String = "D1"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook
' Source
Dim rng As Range
With wb.Worksheets(srcName)
Set rng = defRangeFrLrc(.Columns(srcCols), srcFirstRow, srcLastRowCol)
End With
If rng Is Nothing Then
Exit Sub
End If
' Data
Dim Data As Variant: Data = getDelimited(rng)
If IsEmpty(Data) Then
Exit Sub
End If
' Destination
Dim isWritten As Boolean
With wb.Worksheets(dstName)
isWritten = writeDataToRange(.Range(dstFirst), Data, True)
End With
' Information
If isWritten Then
MsgBox "Data transferred.", vbInformation, "Success"
Else
MsgBox "An error occurred.", vbCritical, "Fail"
End If
End Sub
' Compare with 'joinData' to understand what can go wrong.
Sub joinDataShort()
' Source
Const srcName As String = "Sheet1"
Const srcCols As String = "A:B"
Const srcLastRowCol As Long = 2
Const srcFirstRow As Long = 1
' Destination
Const dstName As String = "Sheet1"
Const dstFirst As String = "D1"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook
' Source
Dim rng As Range
With wb.Worksheets(srcName)
Set rng = defRangeFrLrc(.Columns(srcCols), srcFirstRow, srcLastRowCol)
End With
' Data
Dim Data As Variant: Data = getDelimited(rng)
' Destination
writeDataToRange wb.Worksheets(dstName).Range(dstFirst), Data, True
End Sub
Function defRangeFrLrc( _
rng As Range, _
Optional ByVal FirstRow As Long = 1, _
Optional ByVal LastRowColumn As Long = 1) _
As Range
On Error GoTo clearError
If Not rng Is Nothing Then
Dim cel As Range
With rng
Set cel = .Columns(LastRowColumn) _
.Resize(.Rows.Count - FirstRow + 1).Offset(FirstRow - 1).Find( _
What:="*", _
LookIn:=xlFormulas, _
SearchDirection:=xlPrevious)
If Not cel Is Nothing Then
Set defRangeFrLrc = .Resize(cel.Row - FirstRow + 1) _
.Offset(FirstRow - 1)
End If
End With
End If
ProcExit:
Exit Function
clearError:
Resume ProcExit
End Function
Function getDelimited( _
rng As Range, _
Optional ByVal Delimiter As String = ",") _
As Variant
On Error GoTo clearError
' Arrays
With rng.Columns(1)
Dim rCount As Long
rCount = .Rows.Count - Application.CountBlank(.Offset)
Dim Data As Variant: Data = .Resize(, 2).Value
End With
Dim sCount As Long: sCount = UBound(Data, 1)
Dim Result() As String: ReDim Result(1 To rCount, 1 To 2)
' Headers
Result(1, 1) = Data(1, 1)
Result(1, 2) = Data(1, 2)
' Body
Dim arl As Object: Set arl = CreateObject("System.Collections.ArrayList")
Dim i As Long
Dim k As Long: k = 1
Dim cIndex As Long: cIndex = 1
Dim doAdd As Boolean
For i = 2 To sCount
If Len(Data(i, 1)) > 0 Then
If i > 2 Then
Result(cIndex, 2) = Join(arl.ToArray, Delimiter)
arl.Clear
End If
k = k + 1
cIndex = k
Result(k, 1) = Data(i, 1)
End If
arl.Add Data(i, 2)
Next i
Result(cIndex, 2) = Join(arl.ToArray, Delimiter)
' Result
getDelimited = Result
ProcExit:
Exit Function
clearError:
Resume ProcExit
End Function
Function writeDataToRange( _
FirstCellRange As Range, _
Data As Variant, _
Optional ByVal ClearToBottom As Boolean = False, _
Optional ByVal ClearWorksheet As Boolean = False) _
As Boolean
On Error GoTo clearError
With FirstCellRange.Resize(, UBound(Data, 2))
If ClearWorksheet Then
.Worksheet.Cells.Clear
Else
If ClearWorksheet Then
.Resize(.Worksheet.Rows.Count - .Row + 1).Clear
End If
End If
.Resize(UBound(Data, 1)).Value = Data
End With
writeDataToRange = True
ProcExit:
Exit Function
clearError:
Resume ProcExit
End Function

Answer 2

Here's a simple code which should work for you. See the comments and edit them to suit your needs.
Public Sub RearrangeData()
Dim rngSource As Range, rng As Range
Dim lngOutRow As Long
Application.ScreenUpdating = False
'\\ Set Source Range
Set rngSource = Range("A2:B" & Range("B" & Rows.Count).End(xlUp).Row)
lngOutRow = 1 '\\Define Output Row
For Each rng In rngSource.Columns(1).Cells
If Len(rng.Value) > 0 Then
lngOutRow = lngOutRow + 1
Range("C" & lngOutRow).Value = rng.Value '\\Define Output Column 1
End If
If Len(rng.Offset(0, 1).Value) > 0 Then
If Len(Range("D" & lngOutRow).Value) = 0 Then
Range("D" & lngOutRow).Value = rng.Offset(0, 1).Value '\\Define Output Column 2
Else
Range("D" & lngOutRow).Value = Range("D" & lngOutRow).Value & "," & rng.Offset(0, 1).Value '\\Define Output Column 2
End If
End If
Next rng
Application.ScreenUpdating = True
End Sub