写一个VBA代码：表格A列值保持不变，“B列值、C列值“对应A列值进行批量转置

以下是一个简单的VBA代码示例，它可以实现您所描述的任务：

Sub TransposeValues()
    Dim lastRow As Long
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row ' 获取最后一行
    For i = 2 To lastRow ' 从第二行开始遍历
        value1 = Cells(i, "A").Value ' 获取A列的值
        value2 = Cells(i, "B").Value ' 获取B列的值
        value3 = Cells(i, "C").Value ' 获取C列的值
        Range("A" & i + 2).Value = value2 ' 将B列的值转置到A列下面的第三行
        Range("A" & i + 3).Value = value3 ' 将C列的值转置到A列下面的第四行
        Cells(i, "B").ClearContents ' 清空B列的值
        Cells(i, "C").ClearContents ' 清空C列的值
        i = i + 3 ' 跳过已处理的行
    Next i
End Sub

请在运行代码之前备份您的数据。此代码会修改您的数据。

相关问题

写一个VBA代码：表格A列值进行唯一值列显示，“B列值进行唯一值列做标题显示、C列值“对应A列值、B列值进行批量转置

以下是该VBA代码：

Sub TransposeData()
    Dim lastRow As Long
    Dim uniqueValuesA As Variant
    Dim uniqueValuesB As Variant
    Dim uniqueCountA As Long
    Dim uniqueCountB As Long
    Dim i As Long, j As Long, k As Long
    Dim dictA As Object
    Dim dictB As Object
    Dim arrTransposeA As Variant
    Dim arrTransposeB As Variant
    Dim arrData As Variant
    
    'Get the last row of data in sheet A
    lastRow = Sheets("A").Cells(Rows.Count, 1).End(xlUp).Row
    
    'Get unique values in column A
    uniqueValuesA = Sheets("A").Range("A2:A" & lastRow).Value
    uniqueValuesA = WorksheetFunction.Transpose(WorksheetFunction.Unique(uniqueValuesA))
    uniqueCountA = UBound(uniqueValuesA)
    
    'Get unique values in column B
    uniqueValuesB = Sheets("A").Range("B2:B" & lastRow).Value
    uniqueValuesB = WorksheetFunction.Transpose(WorksheetFunction.Unique(uniqueValuesB))
    uniqueCountB = UBound(uniqueValuesB)
    
    'Create dictionary objects for column A and column B
    Set dictA = CreateObject("Scripting.Dictionary")
    Set dictB = CreateObject("Scripting.Dictionary")
    
    'Populate column A dictionary with unique values as keys
    For i = 1 To uniqueCountA
        dictA.Add uniqueValuesA(i), i
    Next i
    
    'Populate column B dictionary with unique values as keys
    For i = 1 To uniqueCountB
        dictB.Add uniqueValuesB(i), i
    Next i
    
    'Create transpose arrays for column A and column B
    ReDim arrTransposeA(1 To uniqueCountA, 1 To uniqueCountB)
    ReDim arrTransposeB(1 To uniqueCountA, 1 To uniqueCountB)
    
    'Loop through data and populate transpose arrays
    For i = 2 To lastRow
        j = dictA(Sheets("A").Cells(i, 1).Value)
        k = dictB(Sheets("A").Cells(i, 2).Value)
        arrTransposeA(j, k) = Sheets("A").Cells(i, 1).Value
        arrTransposeB(j, k) = Sheets("A").Cells(i, 3).Value
    Next i
    
    'Transpose arrays and paste into sheet B
    Sheets("B").Range("A1").Resize(uniqueCountB, uniqueCountA).Value = WorksheetFunction.Transpose(arrTransposeA)
    Sheets("B").Range("A2").Resize(uniqueCountB, uniqueCountA).Value = WorksheetFunction.Transpose(arrTransposeB)
    
End Sub

此代码将表格A中的列A值进行唯一值列显示，将列B值进行唯一值列做标题显示，将列C值“对应A列值、B列值进行批量转置，并将结果粘贴到表格B中。请确保已经在工作簿中创建了名为"A"和"B"的工作表。

写一个VBA代码：将表格A列值进行唯一值做列显示，“B列值进行唯一值做行标题显示、C列值“对应A列值、B列值进行批量对应转置

以下是该VBA代码：

Sub TransposeData()
    Dim lastRow As Long
    Dim uniqueValuesA As Variant
    Dim uniqueValuesB As Variant
    Dim uniqueCountA As Long
    Dim uniqueCountB As Long
    Dim i As Long, j As Long, k As Long
    Dim dictA As Object
    Dim dictB As Object
    Dim arrTranspose As Variant
    Dim arrData As Variant
    
    'Get the last row of data in sheet A
    lastRow = Sheets("A").Cells(Rows.Count, 1).End(xlUp).Row
    
    'Get unique values in column A
    uniqueValuesA = Sheets("A").Range("A2:A" & lastRow).Value
    uniqueValuesA = WorksheetFunction.Transpose(WorksheetFunction.Unique(uniqueValuesA))
    uniqueCountA = UBound(uniqueValuesA)
    
    'Get unique values in column B
    uniqueValuesB = Sheets("A").Range("B2:B" & lastRow).Value
    uniqueValuesB = WorksheetFunction.Transpose(WorksheetFunction.Unique(uniqueValuesB))
    uniqueCountB = UBound(uniqueValuesB)
    
    'Create dictionary objects for column A and column B
    Set dictA = CreateObject("Scripting.Dictionary")
    Set dictB = CreateObject("Scripting.Dictionary")
    
    'Populate column A dictionary with unique values as keys
    For i = 1 To uniqueCountA
        dictA.Add uniqueValuesA(i), i
    Next i
    
    'Populate column B dictionary with unique values as keys
    For i = 1 To uniqueCountB
        dictB.Add uniqueValuesB(i), i
    Next i
    
    'Create transpose array
    ReDim arrTranspose(1 To uniqueCountA, 1 To uniqueCountB)
    
    'Loop through data and populate transpose array
    For i = 2 To lastRow
        j = dictA(Sheets("A").Cells(i, 1).Value)
        k = dictB(Sheets("A").Cells(i, 2).Value)
        arrTranspose(j, k) = Sheets("A").Cells(i, 3).Value
    Next i
    
    'Transpose array and paste into sheet B
    Sheets("B").Range("A2").Resize(uniqueCountA, uniqueCountB).Value = WorksheetFunction.Transpose(arrTranspose)
    
    'Add column headers to sheet B
    Sheets("B").Range("B1").Resize(1, uniqueCountB).Value = uniqueValuesB
    
    'Add row headers to sheet B
    For i = 1 To uniqueCountA
        Sheets("B").Cells(i + 1, 1).Value = uniqueValuesA(i)
    Next i
    
End Sub

此代码将表格A中的列A值进行唯一值列显示，将列B值进行唯一值行标题显示，将列C值“对应A列值、B列值进行批量对应转置，并将结果粘贴到表格B中。请确保已经在工作簿中创建了名为"A"和"B"的工作表。