excel - Excel：将列解析为可变长度行

Question

我有一列格式如下的数据。特点是新行的指示符是列中的空单元格，但所有块的长度不同。我正在寻找一个 vba 解决方案，并认为应该有一些智能数组公式来做到这一点。

谢谢。

Section

a

b

c

Section

d

e

f

g

Section

h

i

Section
    
j

k

l


becomes:

a b c

d e f g

h I

j k l

这是我第一次“失败”的尝试。它一次捕获四行，但我希望它找到“部分”标记并在该点复制：

Sub Macro_C2R()

Dim row1 As Integer
Dim row2 As Integer

Application.ScreenUpdating = True

row1 = 1   ' Counter for copies
row2 = 2   ' Counter for pasting

' Change first worksheet name to "col_input"
Worksheets.Item(1).Name = "col_input"
' Add Data
Set NewSheet = Worksheets.Add
NewSheet.Name = "Data"
Sheets("col_input").Select


'Check there are not two blank rows else end
Do While Not (Range("A" + (CStr(row1))) = "" And Not (Range("A" + (CStr(row1 + 1))) = ""))
' Test if cell is "empty" i.e. one empty row
    Do While Not (Range("A" + (CStr(row1))) = "")
        Range(Cells.Item(row1, 1), Cells.Item(row1 + 4, 1)).Select
        Application.CutCopyMode = False
        Selection.Copy
        Sheets("Data").Select
        Range(Cells.Item(row2, 1), Cells.Item(row2, 1)).Select
        Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
            , Transpose:=True
' Increment for next copy
        row1 = row1 + 4
' Increment line counter for next paste
        row2 = row2 + 1
' Back to first page
        Sheets("col_input").Select
     Loop
Loop

End Sub

这是我最新的尝试，“几乎”有效，但错过了最后一部分：

Sub copyandpaste()

LastRow = Range("A" & Rows.Count).End(xlUp).Row
blck = 1
j = 2

For i = 2 To LastRow + 1
    If Cells(i, 1) = "Section" Then
        Range(Cells(blck, 1), Cells(i - 1, 1)).Copy
        Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
        blck = i
        j = j + 1
    End If
Next i

End Sub

标签： excelvbaparsingtranspose

Answer 1

创建一个整数来保存要写入结果的单元格的坐标。

Dim targetColumn as integer
Dim targetRow as integer
targetRow = 5 'replace this with the line you want your result in
targetColumn = 1

我建议使用两个嵌套循环。第一个贯穿每一行，第二个贯穿该行的单元格。

Dim i as integer
Dim j as integer

for i = 1 to Cells(Rows.Count, 1).End(xlUp).Row 
   for j = 1 to Cells (i, Columns.Count).End(x1ToLeft).Column
      -> this parses through each cell
   Next 
Next

接下来就是实现将单元格的值写入新行并清除单元格

Cells(targetRow, targetColumn).Value = Cells(i, j).Value
targetColumn = targetColumn + 1
Cells(i, j).Value = ""

现在结合起来，它应该可以工作。

Sub parse()    
Dim targetColumn as integer
Dim targetRow as integer
targetRow = 5 'replace this with the line you want your result in
targetColumn = 1

Dim i as integer
Dim j as integer

for i = 1 to Cells(Rows.Count, 1).End(xlUp).Row 'parses through each row with first cell not empty. 
   for j = 1 to Cells (i, Columns.Count).End(x1ToLeft).Column 'parses through each column in row i
      Cells(targetRow, targetColumn).Value = Cells(i, j).Value
      targetColumn = targetColumn + 1
      Cells(i, j).Value = ""
   Next 
Next
End Sub