主页 / 问题 / 1206128
Accepted
2b4fITin
Asked:2021-11-18 04:23:12 +0800 CST2021-11-18 04:23:12 +0800 CST

column2中的值通过Excel列扩展（转置）为字符串，条件来自column1

  • 772

Column1 具有重复值。Column2 具有其他值。对于column1中的重复值，将column2中的对应值逐列展开。我附上截图（比文字更清晰）。

在此处输入图像描述

我写了一些东西-))，但它的工作非常笨拙..认为它不起作用！

    Sub EqualValFromRowToColumn2()
    
    With Application
    .ScreenUpdating = False
    .EnableEvents = False
        
        Dim rng As Range, wb As Workbook
        Dim Lastrow As Long
        Set wb = ActiveWorkbook
        
        Lastrow = Cells(Rows.Count, 1).End(xlUp).Row
                
        Set rng = Range([a1], Range("a" & Rows.Count).End(xlUp))
                
        For i = 1 To Lastrow
            If Cells(i + 1, 1).Value = Cells(i, 1) Then
                Cells(i + 1, 3).Value = 1
            ElseIf Cells(i + 1, 1).Value <> Cells(i, 1) Then
                Cells(i + 1, 3).Value = 0
            End If
        Next i
        
        For j = 1 To Lastrow
            If Cells(j, 3).Value = 1 Then
                Cells(j, 4).Value = Cells(j, 3).Value + Cells(j - 1, 4).Value
            ElseIf Cells(j, 3).Value = 0 Then
                Cells(j, 4).Value = Cells(j, 3).Value
            End If
        Next j
        
        For k = 1 To Lastrow
            If Cells(k + 1, 1).Value = Cells(k, 1) Then
                Cells(k + 1, 5).Value = Cells(k, 2).Value & ";" & Cells(k + 1, 2).Value & ";" & Cells(k + 2, 2).Value & ";" & Cells(k + 3, 2).Value & ";" & Cells(k + 4, 2).Value & ";" & Cells(k + 5, 2).Value
            End If
        Next k
        
    .ScreenUpdating = True
    .EnableEvents = True
    
    End With
    
End Sub

告诉我狗能翻找什么？

vba

1 个回答

  1. Best Answer

    在数据之前添加第一个空行

    Function fMax(sht As Worksheet, lRow As Long) As Long
    With Application
        fMax = .Max(.CountIf(sht.Range("A1:A" & lRow), sht.Range("A1:A" & lRow)))
    End With
End Function

Sub EqualValFromRowToColumn2()
    Dim aData()
    Dim i As Long, n As Long, j As Long
          
    With Worksheets("Sheet1")
        i = .Cells(.Rows.Count, 1).End(xlUp).Row
        aData = .Range("A1:B" & i).Value
    End With

    ReDim Preserve aData(1 To UBound(aData), 1 To fMax(Worksheets("Sheet1"), i) + 2)
    
    For i = 2 To UBound(aData)
        If aData(i, 1) <> aData(i - 1, 1) Then
            j = 2
        
            For n = i To UBound(aData)
                If aData(i, 1) = aData(n, 1) Then
                    j = j + 1: aData(i, j) = aData(n, 2)
                Else: Exit For
                End If
            Next n
        End If
    Next i
    
    With Application: .ScreenUpdating = False: .EnableEvents = False: End With
    Worksheets("Sheet1").Range("H1").Resize(UBound(aData), UBound(aData, 2)).Value = aData
    With Application: .ScreenUpdating = True: .EnableEvents = True: End With
End Sub

    如果您不使用工作表事件，.EnableEvents则无需禁用它。.ScreenUpdating是的，在工作表上插入单个工作表时禁用屏幕更新 ( ) 并没有多大帮助。

    • 0

相关问题