前言
工作或学习中,是否遇到过这样的事,手上的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