Copy from Merged Cell to individual cell

[vmjamshad]

Hi..

I need to get a VBA code to copy data from merged cell to individual cells. Please see the excel sheet format below:
Copy of Book1.jpg
Thanks in advance -- Jamshad

[mana]

Option Explicit


Sub test()
    Dim c As Range
    Dim f As Range
    Dim s As String
    
    For Each c In Range("d3", Range("d" & Rows.Count).End(xlUp))
    
        Set f = Columns("b").Find(What:=c.Value, LookAt:=xlWhole)
        
        If f Is Nothing Then
            s = ""
        Else
            s = f.Offset(, -1).MergeArea(1).Value
        End If
        c.Offset(, 1).Value = s
    Next
      
End Sub

[p45cal]

if you don't mind just converting the merged cells to individual cells then select the merged cells and run:

Sub blah()
With Selection
  .MergeCells = False
  .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
  .Value = .Value
End With
End Sub

Then you can move the columns around.

[vmjamshad]

Is this dan?

Thanks for the code, but i cannot convert to individual cells as this is a master file and not recommended to change the format. The file has got 100s of data rows and with multiple sheets,

Is there any other way.

Thanks,
Jamshad

if you don't mind just converting the merged cells to individual cells then select the merged cells and run:

Sub blah()
With Selection
  .MergeCells = False
  .SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
  .Value = .Value
End With
End Sub

Then you can move the columns around.

[p45cal]

Well copy the columns to a fresh sheet then.

[vmjamshad]

'

[vmjamshad]

Thanks, This helps

Option Explicit


Sub test()
    Dim c As Range
    Dim f As Range
    Dim s As String
    
    For Each c In Range("d3", Range("d" & Rows.Count).End(xlUp))
    
        Set f = Columns("b").Find(What:=c.Value, LookAt:=xlWhole)
        
        If f Is Nothing Then
            s = ""
        Else
            s = f.Offset(, -1).MergeArea(1).Value
        End If
        c.Offset(, 1).Value = s
    Next
      
End Sub