EXCEL VBA: THE MARCO TO COPY DATA TO MERGED CELLS

  1'******************************************************************************************
  2'*Function : copy from cells to cells
  3'            both source cells and destination cells can be normal or merged
  4'******************************************************************************************
  5Public Sub copyToMergedCells()
  6    
  7    'Consts
  8    Const FUNC_NAME As String = "copyToMergedCells"
  9    
 10    'Vars
 11    Dim arr() As Variant
 12    Dim row As Long: row = 0
 13    Dim col As Long: col = 1
 14    Dim dicIgnoreRow As Object: Set dicIgnoreRow = CreateObject("Scripting.Dictionary")
 15    Dim dicIgnoreCol As Object: Set dicIgnoreCol = CreateObject("Scripting.Dictionary")
 16    
 17    On Error GoTo ErrorHandler
 18        
 19    'check if the data is in text format.
 20    If Application.ClipboardFormats(1) <> xlClipboardFormatText Then MsgBox "The data in the clipboard is not in text format.", vbExclamation, FUNC_NAME: GoTo ExitHandler
 21        
 22    'step 1. move data from clipboard to 2-dimensional array
 23    '   delimiter of rows   : vbCrLf (Carriage return & Line feed)
 24    '   delimiter of columns: vbTab (Tab key)
 25    With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
 26        
 27        .GetFromClipboard
 28        Dim c, d
 29        ReDim arr(1 To 1, 1 To 1)
 30        For Each c In Split(.GetText, vbCrLf)
 31            row = row + 1
 32            If row > 1 Then arr = redimPreserveFor1stDimension(arr, row)
 33            'currentCol: the index of the column currently being stored
 34            Dim currentCol As Long: currentCol = 0
 35            For Each d In Split(c, vbTab)
 36                currentCol = currentCol + 1
 37                If currentCol > col Then
 38                    col = col + 1
 39                    ReDim Preserve arr(1 To row, 1 To col)
 40                End If
 41                arr(row, currentCol) = Trim(d)
 42            Next d
 43        Next c
 44    End With
 45    
 46    'step 2. Record the rows and columnswhose cells is all emnpty
 47    '   Ignore them when pasting is done.
 48    
 49    'check rows
 50    Dim i, j As Long
 51    Dim isIgnore As Boolean
 52    For i = 1 To UBound(arr)
 53        isIgnore = True
 54        For j = 1 To UBound(arr, 2)
 55            'the row isn't ignored if target element isn't empty
 56            If Trim(arr(i, j)) <> "" Then isIgnore = False: Exit For
 57        Next j
 58        If isIgnore Then dicIgnoreRow.Add i, True
 59    Next i
 60    'check columns
 61    For j = 1 To UBound(arr, 2)
 62        isIgnore = True
 63        For i = 1 To UBound(arr)
 64            'the column isn't ignored if target element isn't empty
 65            If Trim(arr(i, j)) <> "" Then isIgnore = False: Exit For
 66        Next i
 67        If isIgnore Then dicIgnoreCol.Add j, True
 68    Next j
 69    
 70    'step 3. paste the array starting from the selected top left cell
 71    Dim k, l As Long
 72    Dim r, tmp As Range
 73    Set r = Selection(1)
 74    For k = 1 To UBound(arr): Do
 75        'continue if the row must be ignored
 76        If dicIgnoreRow.exists(k) Then Exit Do
 77        'store the current range object
 78        Set tmp = r
 79        
 80        For l = 1 To UBound(arr, 2): Do
 81            'continue if the column must be ignored
 82            If dicIgnoreCol.exists(l) Then Exit Do
 83            'paste a value
 84            r.Value = arr(k, l)
 85            'move the paste destination cell one column to the right
 86            Set r = r.Offset(, 1)
 87        Loop While False: Next l
 88        'move the paste destination cell one row to the below
 89        Set r = tmp.Offset(1)
 90    Loop While False: Next k
 91    
 92    Application.CutCopyMode = False
 93    
 94ExitHandler:
 95
 96    Exit Sub
 97    
 98ErrorHandler:
 99
100    MsgBox "An error has occurred and the macro will be terminated." & _
101           vbLf & _
102           "Func Name:" & FUNC_NAME & _
103           vbLf & _
104           "Error No." & Err.Number & vbNewLine & _
105           Err.Description, vbCritical, "Macro"
106        
107    GoTo ExitHandler
108        
109End Sub
110

 1'******************************************************************************************
 2'*Function: expantion of Redim Preserve statement
 3'           Redim Preserve statement can't change the length of first dimension of 2-dimensional array.
 4'           Thus the function works well in such case.
 5'*Arg     : target array
 6'*Arg     : upper limit on the number of elements in the first dimension 
 7'*Return  : True > normal termination; False > abnormal termination
 8'******************************************************************************************
 9Private Function redimPreserveFor1stDimension(ByVal arr As Variant, ByVal sLen As Long) As Variant
10    
11    'Consts
12    Const FUNC_NAME As String = "redimPreserveFor1stDimension"
13    
14    'Vars
15    Dim tspsedArr As Variant
16        
17    On Error Resume Next
18    
19    'transpose target array
20    tspsedArr = WorksheetFunction.Transpose(arr)
21    'step A. Redim the second dimension of the array to the length of argument number
22    ReDim Preserve tspsedArr(1 To UBound(tspsedArr, 1), 1 To sLen)
23
24    redimPreserveFor1stDimension = WorksheetFunction.Transpose(tspsedArr)
25    
26    'step B. if the array is '1 * N' style, by being transposed it turns 1-dimensional array and a error occurs at the step A.
27    '   Instead, at that case, the error will be ignored and the following process replaces it.
28    If Err.Number = 9 Then
29        Dim newArr As Variant
30        Dim i As Long
31        Err.Clear
32        On Error GoTo ErrorHandler
33        ReDim newArr(1 To UBound(arr, 1) + 1, 1 To 1)
34        'reflect a existing value to new array
35        For i = 1 To UBound(arr, 1)
36            newArr(i, 1) = arr(i, 1)
37        Next i
38        redimPreserveFor1stDimension = newArr
39    End If
40    
41ExitHandler:
42
43    Exit Function
44    
45ErrorHandler:
46
47    MsgBox "An error has occurred and the macro will be terminated." & _
48           vbLf & _
49           "Func Name:" & FUNC_NAME & _
50           vbLf & _
51           "Error No." & Err.Number & vbNewLine & _
52           Err.Description, vbCritical, "Macro"
53        
54    GoTo ExitHandler
55        
56End Function