转置不同数量的行直到出现不同数量的空白 VBA

Question

我有如下数据。由空格分隔的块属于一个信息单元，但空格不一致，有时一行有时两行或更多有时none。

我的目标是实现如下输出：-

我对 VBA 很陌生。到目前为止我所尝试的如下：-

Range("A1:A" & nlr).SpecialCells(xlCellTypeBlanks).Value = "" 'nlr is the last row of data calculated
Range("H2:H" & nlr).Formula = "=COUNTA(A2:G2)"   'Data is from A to G Column  

For i = 2 To nlr 
   If Range("A" & i).Value <> "" And Range("K" & i).Value <= 3 Then
       Range("I" & i).Value = Range("A" & i).Value
       Range("J" & i).Value = Range("A" & i + 1).Value
       Range("K" & i).Value = Range("A" & i + 2).Value
       Range("L" & i).Value = Range("A" & i + 3).Value
    End If
Next

也参考了以下解决方案，但对我不起作用

非常感谢任何帮助！！

Answer 1

对于无法停止尝试此请求，我感到抱歉，尽管将来不建议寻求现成代码的答案来产生结果，无论如何请找到下面的代码以满足您的需要，如果有帮助，请接受花点时间理解我在代码中写了什么 :)

Sub t()

Dim rawData As Variant, tranData As Variant
Dim copyrange As Range
Dim lastrow As Long, blankRow As Long, nonBlankRow As Long, irow As Long, findNextRow As Long
Dim destiRow As Long, countV As Long, copytimes As Long, detailsrow As Long, repeatTime As Long
Dim addcontact As Long, copyAddContact As Long

lastrow = Sheet1.UsedRange.Rows.Count + 1
blankRow = 0
repeatTime = 1

For irow = 2 To lastrow
    repeatTime = 1
    destiRow = Sheet2.UsedRange.Rows.Count

    If IsEmpty(Sheet1.Range("A" & irow).Value) Then
        blankRow = Sheet1.Range("A" & irow).Row - 1
        countV = Application.WorksheetFunction.CountA(Sheet1.Range("B" & blankRow - 4, "B" & blankRow))
        rawData = Sheet1.Range("A" & blankRow - 4, "A" & blankRow).Value
        tranData = Application.Transpose(rawData)
        
        For copytimes = 1 To countV
            Set copyrange = Sheet2.Range("A" & destiRow + copytimes, "E" & destiRow + copytimes)
            copyrange.Value = tranData
        Next
        
        For detailsrow = countV To 1 Step -1
            Sheet1.Range("B" & blankRow - (detailsrow - 1), "F" & blankRow - (detailsrow - 1)).Copy _
            Sheet2.Range("F" & destiRow + repeatTime, "I" & destiRow + repeatTime)
            repeatTime = repeatTime + 1
        Next
        
        
        For findNextRow = blankRow + 1 To lastrow
            If Not IsEmpty(Sheet1.Range("A" & findNextRow).Value) Then
                irow = findNextRow - 1
                addcontact = irow - blankRow
                For copyAddContact = 1 To addcontact
                    Sheet2.Cells(destiRow + countV, 10 + copyAddContact).Value = Sheet1.Range("F" & blankRow + copyAddContact).Value
                Next
                Exit For
            End If
        Next
    End If
        
Next

End Sub

Sheet1 中的原始数据（请注意，您不能在最后一行 21 之后添加额外的联系信息，您将很难确定代码是否可以针对实际业务案例进行调整）

这就是您要找的！

这里的Sheet2是指代号sheet（sheet名称可以更改）

转置不同数量的行直到出现不同数量的空白 VBA

Transpose varying number of rows till varying number of blank appears VBA

excel

automation

vba