CODEWITHSUNDEEP
vbaexcel
Nobelium
Nobelium

Reputation: 53

vba - copy into a merged cell is not working

For my userform I have found a very useful code from this site https://www.contextures.com/exceldataentryupdateform.html which includes different functionalities such as retrieval of exisiting data entries. With some small adaptations, the code has worked perfectly - up to the point where I used merged cell in order to make the userform more "compact".

Original Code (Contextures):

Private Sub Worksheet_Change(ByVal Target As Range)

Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim rngA As Range
Dim rngDE As Range

Dim lRec As Long
Dim lRecRow As Long
Dim lLastRec As Long
Dim lastRow As Long
Dim lCellsDE As Long
Dim lColHist As Long

Set rngA = ActiveCell
Set inputWks = Worksheets("Input")
Set historyWks = Worksheets("PartsData")
Set rngDE = inputWks.Range("OrderEntry")
lCellsDE = rngDE.Cells.Count
lColHist = 3 'order data to copy starts in this column on data sheet

  Application.EnableEvents = False

Select Case Target.Address
  Case Me.Range("OrderSel").Address
    Me.Range("CurrRec").Value = Me.Range("SelRec").Value
  Case Me.Range("OrderID").Address
    If Range("CheckID") = True Then
      Me.Range("OrderSel").Value = Me.Range("OrderID").Value
      Me.Range("CurrRec").Value = Me.Range("SelRec").Value
    Else
      Me.Range("OrderSel").ClearContents
      Me.Range("CurrRec").Value = 0
    End If
  Case Else
    GoTo exitHandler
End Select


  With historyWks
      lastRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row - 1
      lLastRec = lastRow - 1
  End With

  With historyWks
      lRec = inputWks.Range("CurrRec").Value
      If lRec > 0 And lRec <= lLastRec Then
        lRecRow = lRec + 1
        .Range(.Cells(lRecRow, lColHist), .Cells(lRecRow, lCellsDE)).Copy
        rngDE.Cells(1, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
        rngA.Select
    End If
  End With


exitHandler:
Application.EnableEvents = True
Exit Sub

End Sub

My Code: 

Private Sub Worksheet_Change(ByVal Target As Range)

Dim historyWks As Worksheet  '"All Entries" Worksheet
Dim inputWks As Worksheet    '"Userform" Worksheet
Dim rngA As Range
Dim rngDE As Range

Dim lRec As Long
Dim lRecRow As Long
Dim lLastRec As Long
Dim lastRow As Long

Set inputWks = Worksheets("Userform")
Set historyWks = Worksheets("All Entries")
Set rngA = inputWks.Range("UserSel")

Application.EnableEvents = False

Select Case Target.Address
  Case Me.Range("UserSel").Address
    Me.Range("CurrRec").Value = Me.Range("SelRec").Value
  Case Me.Range("Form_UserID").Address
    If Range("CheckID") = True Then
      Me.Range("UserSel").Value = Me.Range("Form_UserID").Value
      Me.Range("CurrRec").Value = Me.Range("SelRec").Value
    Else
      Me.Range("UserSel").ClearContents
      Me.Range("CurrRec").Value = 0
    End If
  Case Else
    GoTo exitHandler
End Select

  With historyWks
      lastRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row - 1
      lLastRec = lastRow - 2
  End With

   With historyWks
      lRec = inputWks.Range("CurrRec").Value
      If lRec > 0 And lRec <= lLastRec Then
        lRecRow = lRec + 2
     .Range(.Cells(lRecRow, 2), .Cells(lRecRow, 2)).Copy
    inputWks.Range("Form_UserID").PasteSpecial Paste:=xlPasteValues, Transpose:=False
     .Range(.Cells(lRecRow, 3), .Cells(lRecRow, 3)).Copy
    inputWks.Range("Form_LastName").PasteSpecial Paste:=xlPasteValues, Transpose:=False
     .Range(.Cells(lRecRow, 4), .Cells(lRecRow, 4)).Copy
    inputWks.Range("Form_FirstName").PasteSpecial Paste:=xlPasteValues, Transpose:=False
     .Range(.Cells(lRecRow, 5), .Cells(lRecRow, 5)).Copy
    inputWks.Range("Form_Address").PasteSpecial Paste:=xlPasteValues, Transpose:=False
     .Range(.Cells(lRecRow, 6), .Cells(lRecRow, 6)).Copy
    inputWks.Range("Form_Citizenship").PasteSpecial Paste:=xlPasteValues, Transpose:=False
        rngA.Select
    End If
  End With

exitHandler:
Application.EnableEvents = True
Exit Sub

End Sub

Now, it gives me the error message: "To do this, all the merged cells need to be the same size."

I also tried...

     .Range(.Cells(lRecRow, 2), .Cells(lRecRow, 2)).Value = inputWks.Range("Form_UserID").Value
     .Range(.Cells(lRecRow, 3), .Cells(lRecRow, 3)).Value = inputWks.Range("Form_LastName").Value
     .Range(.Cells(lRecRow, 4), .Cells(lRecRow, 4)).Value = inputWks.Range("Form_FirstName").Value
     .Range(.Cells(lRecRow, 5), .Cells(lRecRow, 5)).Value = inputWks.Range("Form_Address").Value
     .Range(.Cells(lRecRow, 6), .Cells(lRecRow, 6)).Value = inputWks.Range("Form_Citizenship").Value

... which doesn't work either.

Upvotes: 0

Views: 1917

Answers (1)

Pᴇʜ
Pᴇʜ

Reputation: 57683

Merged cells are evil! Try to avoid them by using the "Center Across Selection" text alignment from the menu "Format Cells -> Alignment":

  • Select a range of cells in a single row (as you would when merging cells).
  • Right-Click > Format Cells (Ctrl+1 is the keyboard shortcut)
  • Click the Alignment tab
  • Click the Horizontal drop down arrow and select "Center Across Selection"
  • Click OK.

See: Stop merging cells!

Upvotes: 3

Related Questions