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

kamranyd

Board Regular
Joined
Apr 24, 2018
Messages
152
Office Version
  1. 2021
Platform
  1. Windows
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?

VBA Code:
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
 

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.
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.

Screen Shot 2024-03-09 at 5.05.15 PM.png
 
Upvote 0
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.
 
Upvote 0
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.
 
Upvote 0
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.
 
Upvote 0
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
 
Upvote 0
Try
VBA Code:
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
 
Upvote 0
Try
VBA Code:
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.

 
Upvote 0

Forum statistics

Threads
1,223,099
Messages
6,170,108
Members
452,302
Latest member
TaMere

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top