Excel VBA用于插入列和拆分单元格内容

I have an Excel sheet which contains following content:

我有一张Excel表格,其中包含以下内容:

I have worked on VBA code which does following:-

我一直致力于VBA代码,它具有以下功能: -

Find the column having Header ABC

找到具有标题ABC的列

Insert two new columns adjacent to ABC with name of AAA and BBB

在ABC旁边插入两个新列,名称为AAA和BBB

Then split the ABC cell content into respective cells of AAA and BBB; note (ABC column may have one one line in some cases )

然后将ABC细胞内容分成AAA和BBB的各个细胞;注意(ABC列在某些情况下可能只有一行)

Follow step (3) till end of column ABC content.

按照步骤(3)直到列ABC内容结束。

End result should look like this:

最终结果应如下所示:

I have written following code :-

我写了以下代码: -

Sub Num()
Dim rngDHeader As Range
Dim rngHeaders As Range
Set rngHeaders = Range("1:1") 'Looks in entire first row; adjust as needed.
Set rngDHeader = rngHeaders.Find("ABC")

Sub sbInsertingColumns()
'Inserting a Column at Column B
rngDHeader.EntireColumn.Insert
'Inserting 2 Columns from C
rngDHeader.EntireColumn.Insert
 Dim rngDHeader As Range
   Dim sText As String
   Dim aText As Variant 'array
   Dim i As Long        'number of array elements

   Set rngDHeader = Sheets("Sheet1").Range("C2")

   Do Until rng = ""

      'split the text on carriage return character chr(10)
      aText = Split(rngDHeader.Value, Chr(10))

      'get the number of array elements
      i = UBound(aText)

      'build the output text string
      sText = aText(i - 2) & Chr(10) _
              & aText(i - 1) & Chr(10) _
              & aText(i)

      'output
      rngDHeader.Offset(, 1) = sText

      Set rngDHeader = rngDHeader.Offset(1, 0)
   Loop

   Set rngDHeader = Nothing

End Sub

Can anyone help me with this?

谁能帮我这个?

1 个解决方案

#1

Numbered as per your question:

根据您的问题编号:

1.Find the Column having Header ABC

1.找到具有标题ABC的列

Dim colNum as Integer
colNum = ActiveSheet.Rows(1).Find(what:="ABC", lookat:=xlWhole).Column

2.Insert Two new Column Adjacent to ABC with Name of AAA and BBB

2.插入两个与ABC相邻的新列,名称为AAA和BBB

' Done twice to insert 2 new cols
ActiveSheet.Columns(colNum + 1).Insert    
ActiveSheet.Columns(colNum + 1).Insert

' New col headings
ActiveSheet.Cells(1, colNum + 1).Value = "AAA"
ActiveSheet.Cells(1, colNum + 2).Value = "BBB"

3.Then Split the ABC cell content into respective AAA and BBB; note (ABC column may have one one line in some cases )

3.然后将ABC小区内容分成AAA和BBB;注意(ABC列在某些情况下可能只有一行)

and

4.Follow the process till end of column ABC content.

4.遵循流程直到列ABC内容结束。

' Define the range to iterate over as the used range of the found column
Dim colRange as Range 
With ActiveSheet
    Set colRange = .Range(.Cells(2, colNum), .Cells(.UsedRange.Rows.Count, colNum))
End With

Dim splitStr() as String

Dim vcell as Range
For Each vcell in colRange

    ' Create an array by splitting on the line break
    splitStr = Split(vcell.value, Chr(10))    

    ' Assign first new column as first array value.
    ActiveSheet.Cells(vcell.row, colNum + 1).Value = splitStr(0)

    ' Assign second new column as second array value. 
    ' First test if there *is* a second array value
    If UBound(splitStr) > 0 Then
        ActiveSheet.Cells(vcell.row, colNum + 2).Value = splitStr(1)        
    End If  

Next vcell

#1