VBA Copy value of merged cells to another sheet-CodePudding

I am aware that there are many questions like this one in this forum. Yet, none of them gives satisfying reply.

I need a macro that will copy values from 3 cells from various sheets (all in the same Excel file): E6 (actually it is a merged cell containing columns EFG), E(FG)5 and E21. Then pastes those values into new sheet into columns A, B and C. There are 2 problems that do not let me solve this issue with traditional copy cell value code or answers in other threads in this forum:

There are 3 cells merged. The number of worksheets might differ for different period of times, and they might change their names as well. This is the code that I have found for another similar problem:

Sub CopyToMaster()

ShtCount = ActiveWorkbook.Sheets.Count
 
For i = 2 To ShtCount
 
Worksheets(i).Activate
 
Range("E6").Select
 
Selection.Copy
Sheets("Master").Activate
 
'Required after first paste to shift active cell down one
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
 
ActiveCell.Offset(0, -3).Select
Selection.PasteSpecial
 
 
Next i
End Sub

Source Data (This is source data, I where I marked with yellow 3 cells that values, I need to copy):

Needed result (Here is the expected outcome, where each from previous yellow marked cells should be pasted in respective column):

Thx for your help.

CodePudding user response：

Please, test the next (working) code. It should be faster than yours, not using clipboard. You must know that the value of a merged range is kept in its top left cell. So, having ranges with a single row, it is enough to try extracting the value of the first marge cells cell:

Sub CopyToMasterWorking()
   Dim ws As Worksheet, wsM As Worksheet, lastR As Long, i As Long
   
   Set wsM = Worksheets("Master")
   wsM.UsedRange.Resize(wsM.UsedRange.rows.count - 1).Offset(1).ClearContents 'clear everything, except headers
   
   For Each ws In ActiveWorkbook.Worksheets
        If ws.name <> wsM.name Then
            lastR = wsM.UsedRange.SpecialCells(xlCellTypeLastCell).row   1
            wsM.Range("A" & lastR).Value = ws.Range("E6").Value
            wsM.Range("B" & lastR).Value = ws.Range("E5").Value
            wsM.Range("C" & lastR).Value = ws.Range("E21").Value
            wsM.Range("D" & lastR).Value = ws.name 'you may comment  this line if not necessary...
        End If
   Next ws
End Sub

I thought that it would be good to have a little traceability, I mean to know from which sheet the data comes (per row). If you do not need it, you may comment last code line from iteration between sheets.

The code also clear everything in "Master" sheet, except the header, before starting processing. If you need to add at the end of existing data, you have to comment that line, too.

Please, send some feedback after testing it. If something not clear enough, do not hesitate to ask for clarification...

CodePudding user response：

I think your only problem is copying merged-cell ranges, correct? This shows how to copy a merged-cell range to 1) same-sized range 2) single cell 3) different-sized range:

Option Explicit

Sub sub1()
  Dim variant1
  Cells.Delete
  
  ' define a merged-cell range and populate:
  Range("b2:c3").MergeCells = True
  Range("b2:c3") = " B2:C3 "
  
  ' to copy to a like-sized merged-cell range:
  Range("b5:c6").MergeCells = True
  Range("b2:c3").Copy Range("b5:c6")
  
  ' to copy to a single cell
  variant1 = Range("b2:c3").Value
  Range("b8").Value = variant1
  
  ' to copy to a different-sized merged-cell range:
  Range("b10:d12").MergeCells = True
  variant1 = Range("b2:c3").Value
  Range("b10:d12").Value = variant1
End Sub