使用二维数组和字典去重，VBA实现Excel工作表行列数据转换

使用二维数组和字典去重，VBA实现Excel工作表行列数据转换

引用

CSDN

1.

https://blog.csdn.net/BeijixingVBA/article/details/139237293

在处理Excel数据时，经常会遇到需要将行和列的数据进行调换的情况。本文将介绍如何使用VBA编程语言，通过二维数组和字典去重的方法，实现Excel工作表中行、列数据的转换。

一、效果如图：

如果手动调整的话，就需要“筛选”—“复制粘贴”，假如“姓名”列不一致，还可能要用到VLookUP或其他函数，总不能一个个数值对应的去复制粘贴吧。
还是用VBA代码吧，只要你能想到，几乎都能做到。

二、操作思路：

1、运用字典，对“姓名”列的人员名单去重，并将去重后的姓名保存在一维数组内；
2、定义二维数组，分别保存姓名及对应的“科目”“分数”；
3、创建新工作表，将所有科目名称放在第一行；
4、将所有去重后姓名放在新工作表“姓名”列，并添加序号，并将二维数组的数值依次放到对应单元格。

三、代码如下：

1.创建二维数组并赋值

Function ArrTwo(arrA() As String, RowsCount As Integer)  '创建二维数组并赋值
  ReDim arrA(RowsCount, 3)
  For i = 2 To RowsCount
    arrA(i - 2, 0) = ActiveSheet.Cells(i, 2).Value
    arrA(i - 2, 1) = ActiveSheet.Cells(i, 3).Value
    arrA(i - 2, 2) = ActiveSheet.Cells(i, 4).Value
  Next
End Function

2.字典去重

Function dcArr(arr() As String, RowsCount As Integer, Col As String, nameKm As String) '字典去重
    Dim rng As Range
    Dim rng1 As Range
    Dim d As Object
    Dim ws As Worksheet
    Dim c As Integer
    ReDim arr(RowsCount)
    On Error Resume Next
    Set rng = Sheets("学生成绩表").Range(Col, Sheets("学生成绩表").Range(Col).End(xlDown))
    Set d = CreateObject("Scripting.Dictionary")
    For Each rng1 In rng
        If rng1.Value <> nameKm And Not d.Exists(rng1.Value) Then
            d.Add rng1.Value, 0
            arr(c) = rng1.Value
            c = c + 1
        End If
    Next rng1
End Function

3.新工作表创建及赋值

Function RowsAndCol()  '新工作表创建及赋值
  Dim sheetNameS As String
  Dim sheetNameF As String
  Dim arrA() As String
  Dim arrName() As String
  Dim arrKM() As String
  Dim RowsCount1 As Integer
  Dim RowsCount2 As Integer
  Dim Xuhao As String
  Dim Name As String
  Dim KeMu As String
  Dim RowFinal As Integer
  Dim ColFinal As Integer
  Dim i, j, m As Integer
  Dim ws As Worksheet
  Dim WsExist As Boolean
  WsExist = False
  sheetNameS = "学生成绩表"
  sheetNameF = "学生成绩表修改后"
  Xuhao = Sheets(sheetNameS).Cells(1, 1).Value
  Name = Sheets(sheetNameS).Cells(1, 2).Value
  KeMu = Sheets(sheetNameS).Cells(1, 3).Value
  RowsCount1 = Sheets(sheetNameS).[B1].End(xlDown).Row
  RowsCount2 = Sheets(sheetNameS).[B1].End(xlDown).Row
  Call ArrTwo(arrA(), RowsCount1)
  Call dcArr(arrName(), RowsCount2, "B1", Name)
  Call dcArr(arrKM(), RowsCount2, "C1", KeMu)
  For Each ws In Worksheets
    If ws.Name = sheetNameF Then  '判断工作表是否存在
      WsExist = True
    End If
  Next
  If WsExist = False Then         '添加修改后工作表
    Worksheets.Add before:=Worksheets(1)
    ActiveSheet.Name = sheetNameF
    ActiveSheet.Cells(1, 1) = Xuhao
    ActiveSheet.Cells(1, 2) = Name
  End If
  For i = 0 To RowsCount2         '姓名
    If arrName(i) <> "" Then
        Sheets(sheetNameF).Cells(i + 2, 2) = arrName(i)
        Sheets(sheetNameF).Cells(i + 2, 1) = i + 1    '序号
    Else
      Exit For
    End If
  Next
  For i = 0 To RowsCount2        '科目
    If arrKM(i) <> "" Then
       Sheets(sheetNameF).Cells(1, i + 3) = arrKM(i)
    Else
      Exit For
    End If
  Next
  RowFinal = Sheets(sheetNameF).[B1].End(xlDown).Row
  ColFinal = Sheets(sheetNameF).Range("A1").End(xlToRight).Column
  For m = 0 To RowsCount1
    For i = 2 To RowFinal
      For j = 3 To ColFinal
        If Sheets(sheetNameF).Cells(i, 2).Value = arrA(m, 0) And Sheets(sheetNameF).Cells(1, j).Value = arrA(m, 1) Then
          Sheets(sheetNameF).Cells(i, j) = arrA(m, 2)
        End If
      Next
    Next
  Next
  Sheets(sheetNameF).UsedRange.Borders.LineStyle = xlContinuous '添加边框
End Function
Sub transform()
  RowsAndCol
End Sub