急: EXCEL 問題 (macro, vba)

假設沒有 「：」符
A欄：同學名稱
B欄：資料

Sub x2()

Dim arr(1 To 10000, 1 To 6)

Dim R As Integer
Dim NR As Long: NR = [A65536].End(xlUp).Row()
Dim lastdata As String: lastdata = ""

If NR < 3 Then
MsgBox "當前工作表不含資料，程式結束"
Exit Sub
End If

For R = 1 To NR

dat = Trim(Cells(R, 1).Value)
If dat = "" Then GoTo 112

If Not lastdata = dat Then
lastdata = dat
counter = counter + 1
arr(counter, 1) = dat
End If

dat = Trim(Cells(R, 2).Value)
If dat Like "[12]#" Then
arr(counter, 2) = dat
ElseIf dat Like "#[A-Za-z]" Then
arr(counter, 3) = dat
ElseIf dat Like "###[Cc][Mm]" Then
arr(counter, 4) = dat
ElseIf dat Like "##[Kk][Gg]" Then
arr(counter, 5) = dat
Else
arr(counter, 6) = dat
End If

112 ' next row
Next

Sheets.Add.Name = "NewlyGeneratedSheet"
[A2].Resize(counter, 6) = arr
[A1].Resize(1, 5) = Split("學生 年齡 班別 身高 體重")
Rows(2).Select
ActiveWindow.FreezePanes = True

End Sub



2009-04-21 21:03:26 補充：
arr(counter, 6) = dat 防你有額外資料，也一併抄過去。

個人認為, 用什麼方法, 是視乎學生的資料量及是否一次性工作, 還是原資料尚會更改及新增, 新資料亦需即時自動更新。
如須自動更新, 可考慮用函數(Function)

Sub organize()
Dim totalRecInt, i, j, y, z As Integer
Dim str As Variant
Dim sheet1, sheet2 As Worksheet

Set sheet1 = Worksheets("Sheet1") '資料工作表名稱
Set sheet2 = Worksheets("Sheet2") '輸出工作表名稱
y = 4 '假設四行為一網紀錄

totalRecInt = sheet1.Rows(Rows.Count).End(xlUp).Row

For i = 1 To totalRecInt Step y
For j = 0 To y - 1

z = InStr(1, sheet1.Cells(i + j, 1), ":")
If z = 0 Then
MsgBox ("行 " & i + j & " 資料 [" & sheet1.Cells(i + j, 1) & "] 沒有用冒號分隔")
sheet1.Cells(i + j, 1).Activate
End
End If

str = Split(sheet1.Cells(i + j, 1), ":") '用冒號分隔資料
If j = 0 Then
sheet2.Cells(WorksheetFunction.RoundUp(i / 4, 0), 1) = Trim(str(0))
sheet2.Cells(WorksheetFunction.RoundUp(i / 4, 0), 2) = Trim(str(1))
Else
sheet2.Cells(WorksheetFunction.RoundUp(i / 4, 0), j + 2) = Trim(str(1))
End If
Next j
Next i

End Sub

殺雞不必用牛刀, 不必用到 macro. 這是典型的 "轉置" 問題.
1. highlight 你要轉置的區域
2. 點選 copy
3. 將 cursor click 在 欲轉置的新cell
4. 點選 選擇性貼上, 並在 dialog box tick 轉置, 再按 確定
5. 完成