|
楼主 |
发表于 2017-10-15 11:04
|
显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
本帖最后由 乐乐2006201505 于 2017-10-15 12:44 编辑
数据源格式转置后,代码稍作修改即可,可修改性强,非常实用,再次感谢!
'Write By:Micro,QQ:79833378,微信:dgpigs,Q群:288507620
Sub 调整格式提班级新格式()
Dim vData As Variant, nRow As Integer, nCol As Integer
Dim oDic As Object
Dim sWeek As String, nClass As Integer, nLesson As Integer, sTeacher As String
Dim vFill As Variant
Set oDic = CreateObject("Scripting.Dictionary")
r = Sheet4.Range("a65536").End(3).Row
vData = Sheet4.Range("a2:ao" & r).Value
For nCol = 2 To UBound(vData, 2)
If vData(1, nCol) <> "" Then sWeek = Trim(vData(1, nCol))
If vData(2, nCol) <> "" Then nLesson = Val(vData(2, nCol))
For nRow = 3 To UBound(vData)
nClass = Val(vData(nRow, 1))
If vData(nRow, nCol) <> "" Then
sTeacher = Trim(vData(nRow, nCol))
If oDic.Exists(sTeacher & "|" & sWeek & "|" & nLesson) Then
oDic(sTeacher & "|" & sWeek & "|" & nLesson) = oDic(sTeacher & "|" & sWeek & "|" & nLesson) & "," & nClass
Else
oDic(sTeacher & "|" & sWeek & "|" & nLesson) = nClass
End If
End If
Next
Next
vData1 = Sheet6.UsedRange.Value
ReDim vFill(3 To UBound(vData1), 3 To UBound(vData1, 2))
For nCol = 3 To UBound(vData1, 2)
If vData1(2, nCol) <> "" Then nClass = Val(vData1(2, nCol))
If vData1(2, nCol) <> "" Then
sWeek = Trim(vData1(2, nCol))
nLesson = 1
Else
nLesson = nLesson + 1
End If
For nRow = 3 To UBound(vData1)
sTeacher = Trim(vData1(nRow, 1))
If oDic.Exists(sTeacher & "|" & sWeek & "|" & nLesson) Then
vFill(nRow, nCol) = oDic(sTeacher & "|" & sWeek & "|" & nLesson)
End If
Next
Next
Sheet6.[C3].Resize(UBound(vFill) - 2, UBound(vFill, 2) - 2) = vFill
End Sub
|
|