You are here:

Excel/Transpose action macro with same format of cell

Advertisement


Question
Hello Tom,
Hope you are fine.

previously i asked you for a macro where my input data is as below

  WRTIN   BRTIN   DRTIN   
BOM   562   458   658   
DEL   123   654   789   
MAA   741   852   963   
CCU   159   753   127   

and i want the output data as below (like transpose action with intersecting cells)

BOM   WRTIN   562
DEL   WRTIN   123
MAA   WRTIN   741
CCU   WRTIN   159
     
BOM   BRTIN   458
DEL   BRTIN   654
MAA   BRTIN   852
CCU   BRTIN   753
     
BOM   DRTIN   658
DEL   DRTIN   789
MAA   DRTIN   963
CCU   DRTIN   127

for that you had provided me the below macro which is absolutely working fine.

******

Sub abc()
Dim sh As Worksheet
Dim sh1 As Worksheet
Dim rCity As Range, rCode As Range
Dim cell As Range, cell1 As Range
Dim rw As Long

Set sh = Worksheets("Sheet1")
Set rCity = sh.Range("A2", sh.Range("A2").End(xlDown))
Set rCode = sh.Range("B1", sh.Range("B1").End(xlToRight))
Worksheets.Add After:=Worksheets(Worksheets.Count)
Set sh1 = ActiveSheet
rw = 2
For Each cell In rCity
For Each cell1 In rCode
 sh1.Cells(rw, 1) = cell
 sh1.Cells(rw, 2) = cell1
 sh1.Cells(rw, 3) = Intersect(cell.EntireRow, cell1.EntireColumn)
 rw = rw + 1
Next
 rw = rw + 1
Next

End Sub

****

but this macro is giving result in paste special format(i.e if my input data cell is highlighted with any color (e.g. yellow OR red color), my output data cells are normal and without any formatting.(i.e like paste specials)

can you please modify the above macro in such a way that when my input data sheet cells will have any format (color, bold text etc.)that should same reflect in my output sheet.

Hope i am explaining well.

Thanks
Rakesh

Answer
Rakesh,

see if this is what you want:

Sub abc()
Dim sh As Worksheet
Dim sh1 As Worksheet
Dim rCity As Range, rCode As Range
Dim cell As Range, cell1 As Range
Dim rw As Long

Set sh = Worksheets("Sheet1")
Set rCity = sh.Range("A2", sh.Range("A2").End(xlDown))
Set rCode = sh.Range("B1", sh.Range("B1").End(xlToRight))
Worksheets.Add After:=Worksheets(Worksheets.Count)
Set sh1 = ActiveSheet
rw = 2
For Each cell In rCity
For Each cell1 In rCode
cell.Copy sh1.Cells(rw, 1)
cell1.Copy sh1.Cells(rw, 2)
Intersect(cell.EntireRow, cell1.EntireColumn).Copy sh1.Cells(rw, 3)
rw = rw + 1
Next
rw = rw + 1
Next

End Sub

--
Regards,
Tom Ogilvy

About Excel
This topic answers questions related to Microsoft Excel spreadsheet (or workbook) stand-alone or Mircrosoft Office Excel including Excel 2003, Excel 2007, Office 2000, and Office XP. You can get Excel help on Excel formulas(or functions), Excell macros, charting in Excel, advanced features, and the general use of Excel. This does not provide a general Excel tutorial nor the basics of using a spreadsheet. It provides specific answers to using Microsoft Excel only. If you do not see your Excel question answered in this area then please ask an Excel question here

Excel

All Answers


Answers by Expert:


Ask Experts

Volunteer


Tom Ogilvy

Expertise

Selected as an Excel MVP by Microsoft since 1999. Answering Excel questions in Allexperts since its inception in 2001. Able to answer questions on almost all aspects of Excel's internal capabilities. If seeking a VBA solution, please specify that in your question itself so I give you the answer you want. [Excel has weak protection - if you are distributing an application, I don't answer questions on how to protect your project from your users.]

Experience

Extensive experience.

Education/Credentials
Master of Science (MS) degree Operations Research (ORSA)

Awards and Honors
Microsoft MVP in Excel.

©2016 About.com. All rights reserved.