रंगों (और अन्य फ़ॉन्ट विशेषताओं) को प्राप्त करने का सबसे आसान तरीका ए है Copy प्रक्रिया। यदि यह बहुत धीमा है, तो हम अन्य विकल्पों की जांच कर सकते हैं।
मै सुझाव दूंगा
- मूल डेटा को नए वर्कशीट में कॉपी करें (ताकि अपने मूल डेटा को संरक्षित करें)
- अंतिम निश्चित कॉलम निर्धारित करें - आपके नमूने में यह लेबल वाला कॉलम है कमजोर पड़ने:
- अंतिम निश्चित कॉलम +1 के बाद, अंतिम वास्तविक कॉलम में हर दूसरे कॉलम में एक नया कॉलम डालें
- प्रत्येक डेटा की दूसरी पंक्ति में और दाईं ओर एक सेल में (अब खाली कॉलम में) जानकारी कॉपी करें।
- कॉलम A में रिक्त सभी पंक्तियों को हटा दें
Option Explicit
Sub Interleave2()
Dim wsSrc As Worksheet, wsRes As Worksheet
Dim rSrc As Range, rRes As Range
Dim LastRow As Long, LastCol As Long
Dim LastFixedColumn As Long
Dim I As Long, J As Long, K As Long, L As Long
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
With wsSrc
LastRow = .Cells.Find(what:="*", after:=.Cells(1, 1), _
LookIn:=xlFormulas, searchorder:=xlByRows, _
searchdirection:=xlPrevious).Row
LastCol = .Cells.Find(what:="*", after:=.Cells(1, 1), _
LookIn:=xlFormulas, searchorder:=xlByColumns, _
searchdirection:=xlPrevious).Column
Set rSrc = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With
LastFixedColumn = rSrc.Find(what:="Dilution:", after:=rSrc.Cells(1)).Column
Application.ScreenUpdating = False
wsRes.Cells.Clear
rSrc.Copy wsRes.Cells(1, 1)
For I = LastCol To LastFixedColumn + 2 Step -1
Cells(1, I).EntireColumn.Insert shift:=xlToRight
Next I
With wsRes
LastRow = .Cells.Find(what:="*", after:=.Cells(1, 1), _
LookIn:=xlFormulas, searchorder:=xlByRows, _
searchdirection:=xlPrevious).Row
LastCol = .Cells.Find(what:="*", after:=.Cells(1, 1), _
LookIn:=xlFormulas, searchorder:=xlByColumns, _
searchdirection:=xlPrevious).Column
Set rRes = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With
For I = 3 To rRes.Rows.Count Step 2
For J = LastFixedColumn + 1 To rRes.Columns.Count Step 2
rRes(I, J).Copy rRes(I - 1, J + 1)
Next J
Next I
With rRes
.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
With .EntireColumn
.ColumnWidth = 255
.AutoFit
End With
.EntireRow.AutoFit
End With
Application.ScreenUpdating = True
End Sub
