How to copy data from single cells to merge cells and vice versa

[kamranyd]

i have these codes which copy data from data sheet to quot sheet was working fine, but now my quot sheet has few merge cells now it dont copy. does merge cells dont copy values from single cells sheets?

Sub search_quot()
    Dim Quot_No As String, Fnd As Range, Ws1 As Worksheet, Ws2 As Worksheet, FileNameRef As String, X As Long, Y As Long: Y = 17
    
    Sheets("Quot").Unprotect
    Application.ScreenUpdating = False
    
    Set Ws1 = Sheets("database")
    Set Ws2 = Sheets("QUOT")
    
    FileNameRef = Range("I3").Value
    
    Set Fnd = Ws1.Range("A:A").Find(Ws2.Range("I3").Value, , , xlWhole, , , , , False)
    If Fnd Is Nothing Then MsgBox "Quotation Number [-]> " & FileNameRef & " <[-]" & vbNewLine & "Not found in Quotation Database.", vbExclamation, "Quote Search ERROR": Exit Sub
    
    With Ws2
        .Range("I4").Value = Fnd.Offset(, 1).Value
        .Range("I5").Value = Fnd.Offset(, 128).Value
        .Range("C8").Value = Fnd.Offset(, 2).Value
        .Range("C9").Value = Fnd.Offset(, 3).Value
        .Range("A49").Value = Fnd.Offset(, 129).Value
        .Range("A51").Value = Fnd.Offset(, 130).Value
        .Range("H61").Value = Fnd.Offset(, 7).Value
             For X = 8 To 124 Step 4
            .Range("A" & Y).Resize(, 4).Value = Array(Fnd.Offset(, X).Value, Fnd.Offset(, X + 1).Value, Fnd.Offset(, X + 2).Value, Fnd.Offset(, X + 3).Value)
            Y = Y + 1
        Next X
    End With
     Range("A17").Select
     ActiveWindow.ScrollRow = 1
    'Sheets("Quot").Protect AllowFormattingCells:=True
    Application.ScreenUpdating = True
End Sub

 

[Cubist]

An option is not to merge the cell but to change the format to give it the appearance of a merged cell. Highlight the cells -> Ctrl + 1 -> Alignment -> Horizontal Alignment -> Center Across Selection.

 

[kamranyd]

An option is not to merge the cell but to change the format to give it the appearance of a merged cell. Highlight the cells -> Ctrl + 1 -> Alignment -> Horizontal Alignment -> Center Across Selection.

View attachment 108129

I tried this, but still data is not getting copy.

 

[Cubist]

I tried this, but still data is not getting copy.

Does it work without the alignment formatting? Don't see a reason why it wouldn't.

 

[kamranyd]

Does it work without the alignment formatting? Don't see a reason why it wouldn't.

its not a matter of alignment, i want data should copy from merge cells to a single cell and when i want to retrieve data it should copy from a single cell to a merge cells. these codes work fine when cells are not merge, but i need cells remain merge, so is there any way or need change in these codes to work.

 

[Cubist]

its not a matter of alignment, i want data should copy from merge cells to a single cell and when i want to retrieve data it should copy from a single cell to a merge cells. these codes work fine when cells are not merge, but i need cells remain merge, so is there any way or need change in these codes to work.

Your response suggests that you didn't understand my suggestion in #2. I'm aware that merged cells need to be handled differently in VBA.
My suggestion is to unmerge the cells, then use "Center Across Selection" to give it the appearance of a merged cell but they're actually unmerged. This avoids the need to alter the VBA.

 

[kamranyd]

Your response suggests that you didn't understand my suggestion in #2. I'm aware that merged cells need to be handled differently in VBA.
My suggestion is to unmerge the cells, then use "Center Across Selection" to give it the appearance of a merged cell but they're actually unmerged. This avoids the need to alter the VBA.

yes i tried, still nothing getting copy, i think these line of code need some change,

.Range("A" & Y).Resize(, 4).Value = Array(Fnd.Offset(, X).Value, Fnd.Offset(, X + 1).Value, Fnd.Offset(, X + 2).Value, Fnd.Offset(, X + 3).Value)

these codes work fine if cells are not merge, but my sheet "quot" has merge cells and your given options not working.

 

[kamranyd]

yes i tried, still nothing getting copy, i think these line of code need some change,

.Range("A" & Y).Resize(, 4).Value = Array(Fnd.Offset(, X).Value, Fnd.Offset(, X + 1).Value, Fnd.Offset(, X + 2).Value, Fnd.Offset(, X + 3).Value)

these codes work fine if cells are not merge, but my sheet "quot" has merge cells and your given options not working.

or perhaps you can change these codes, so I can copy data from sheet "quot" which has merge cells to sheet data which has single cell

 

[Cubist]

Try

Sub search_quot()
    Dim Quot_No As String, Fnd As Range, Ws1 As Worksheet, Ws2 As Worksheet, FileNameRef As String, X As Long, Y As Long: Y = 17
    
    Sheets("Quot").Unprotect
    Application.ScreenUpdating = False
    
    Set Ws1 = Sheets("database")
    Set Ws2 = Sheets("QUOT")
    
    FileNameRef = Range("I3").Value
    
    Set Fnd = Ws1.Range("A:A").Find(Ws2.Range("I3").Value, , , xlWhole, , , , , False)
    If Fnd Is Nothing Then MsgBox "Quotation Number [-]> " & FileNameRef & " <[-]" & vbNewLine & "Not found in Quotation Database.", vbExclamation, "Quote Search ERROR": Exit Sub
    
    With Ws2
        .Range("I4").Value = Fnd.Offset(, 1).Value
        .Range("I5").Value = Fnd.Offset(, 128).Value
        .Range("C8").Value = Fnd.Offset(, 2).Value
        .Range("C9").Value = Fnd.Offset(, 3).Value
        .Range("A49").Value = Fnd.Offset(, 129).Value
        .Range("A51").Value = Fnd.Offset(, 130).Value
        .Range("H61").Value = Fnd.Offset(, 7).Value
        
        For X = 8 To 124 Step 4
            For Each cell In .Range("A" & Y & ":D" & Y).Cells
                cell.Value = Fnd.Offset(, X).Value
                If cell.MergeCells Then
                    ' Handle merged cells 
                    cell.MergeCells = False
                    cell.MergeArea.Value = Fnd.Offset(, X).Value
                    cell.MergeCells = True
                End If
                X = X + 1
            Next cell
            Y = Y + 1
        Next X
    End With
    
    Range("A17").Select
    ActiveWindow.ScrollRow = 1
    'Sheets("Quot").Protect AllowFormattingCells:=True
    Application.ScreenUpdating = True
End Sub

 

[kamranyd]

Try

Sub search_quot()
    Dim Quot_No As String, Fnd As Range, Ws1 As Worksheet, Ws2 As Worksheet, FileNameRef As String, X As Long, Y As Long: Y = 17
   
    Sheets("Quot").Unprotect
    Application.ScreenUpdating = False
   
    Set Ws1 = Sheets("database")
    Set Ws2 = Sheets("QUOT")
   
    FileNameRef = Range("I3").Value
   
    Set Fnd = Ws1.Range("A:A").Find(Ws2.Range("I3").Value, , , xlWhole, , , , , False)
    If Fnd Is Nothing Then MsgBox "Quotation Number [-]> " & FileNameRef & " <[-]" & vbNewLine & "Not found in Quotation Database.", vbExclamation, "Quote Search ERROR": Exit Sub
   
    With Ws2
        .Range("I4").Value = Fnd.Offset(, 1).Value
        .Range("I5").Value = Fnd.Offset(, 128).Value
        .Range("C8").Value = Fnd.Offset(, 2).Value
        .Range("C9").Value = Fnd.Offset(, 3).Value
        .Range("A49").Value = Fnd.Offset(, 129).Value
        .Range("A51").Value = Fnd.Offset(, 130).Value
        .Range("H61").Value = Fnd.Offset(, 7).Value
       
        For X = 8 To 124 Step 4
            For Each cell In .Range("A" & Y & ":D" & Y).Cells
                cell.Value = Fnd.Offset(, X).Value
                If cell.MergeCells Then
                    ' Handle merged cells
                    cell.MergeCells = False
                    cell.MergeArea.Value = Fnd.Offset(, X).Value
                    cell.MergeCells = True
                End If
                X = X + 1
            Next cell
            Y = Y + 1
        Next X
    End With
   
    Range("A17").Select
    ActiveWindow.ScrollRow = 1
    'Sheets("Quot").Protect AllowFormattingCells:=True
    Application.ScreenUpdating = True
End Sub

it getting copy but breaking all cells which i merge, i m uploading sample sheet, please check, when i search database it don't copy qty and unit price from database sheet to quot sheet and when i savey data from quot sheet to database sheet it dont copy qty and unit price.

Oilfield.new - Copy.xlsm

Shared with Dropbox

www.dropbox.com