0

## EXCEL VBA 分組導出各類組求解

https://www.mediafire.com/file/sx4bgut2mrfkv3r/VBMS.xlsx/file

1.16筆是「固定」的嗎？
2.會有「4x4」或「3x4+2x2」或「2x8」這種分組法嗎？
peterzxcv iT邦新手 5 級 ‧ 2021-05-05 14:39:12 檢舉
1.不是只固定16格的，讓成員填寫為a4表格基本會42格，基本會少於所以有表格沒序號，另外會在空個幾行又接續下一張表格
2.基本只看同組號就放一起，導出的表我也是用a4的表，大大寫的分法不是很清楚

### 3 個回答

0
rogeryao
iT邦大師 2 級 ‧ 2021-05-05 16:01:14

``````Private Sub CommandButton1_Click()
Dim U As Integer
DataCunt = Worksheets("工作表1").Range("A65536").End(xlUp).Row

'用 CountIf 計算 C 欄位同一字串出現次數,置於 D 欄位
Dim SearchStr As String
For U = RngHead.Row + 1 To DataCunt
SearchStr = Trim(Worksheets("工作表1").Cells(U, 3))
If (SearchStr <> "") Then
Worksheets("工作表1").Cells(U, 4) = WorksheetFunction.CountIf(Worksheets("工作表1").Range("C1:C65536"), SearchStr)
End If
Next

'排序:D ,A 欄位
Columns("A:D").Select
ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Clear
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("工作表1").Sort
.SetRange Range("A1:D" & DataCunt)
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

'產生新格式
Dim OldStr As String
Dim X As Integer
OldStr = ""
X = -1
For U = RngHead.Row + 1 To DataCunt
If (Trim(Worksheets("工作表1").Cells(U, 3)) <> "") Then
If (OldStr = Trim(Worksheets("工作表1").Cells(U, 4))) Then
X = X + 1
Else
If X = -1 Then
X = X + 3
Else
X = X + 4
End If
OldStr = Trim(Worksheets("工作表1").Cells(U, 4))
Worksheets("工作表1").Cells(X - 1, 8) = Trim(Worksheets("工作表1").Cells(U, 4)) & "人小組表"
Worksheets("工作表1").Cells(X, 7) = "序"
Worksheets("工作表1").Cells(X, 8) = "姓名"
Worksheets("工作表1").Cells(X, 9) = "小組"
End If
Worksheets("工作表1").Cells(X + 1, 7) = Trim(Worksheets("工作表1").Cells(U, 1))
Worksheets("工作表1").Cells(X + 1, 8) = Trim(Worksheets("工作表1").Cells(U, 2))
Worksheets("工作表1").Cells(X + 1, 9) = Trim(Worksheets("工作表1").Cells(U, 3))
End If
Next

'清除暫存:D 欄位
Columns("D:D").Select
Selection.ClearContents

End Sub
``````

peterzxcv iT邦新手 5 級 ‧ 2021-05-05 20:19:29 檢舉

rogeryao iT邦大師 2 級 ‧ 2021-05-05 20:38:55 檢舉

1B1 : 第一隊B1
2B1 : 第二隊B1

peterzxcv iT邦新手 5 級 ‧ 2021-05-05 20:45:41 檢舉

rogeryao iT邦大師 2 級 ‧ 2021-05-05 21:48:13 檢舉
``````Private Sub CommandButton1_Click()
Dim U As Integer
DataCunt = Worksheets("工作表1").Range("A65536").End(xlUp).Row

'A,C 合併成 D
For U = RngHead.Row + 1 To DataCunt
If (Trim(Worksheets("工作表1").Cells(U, 3)) <> "") Then
Worksheets("工作表1").Cells(U, 4) = Worksheets("工作表1").Cells(U, 1) & Worksheets("工作表1").Cells(U, 3)
End If
Next

'用 CountIf 計算 D 欄位同一字串出現次數,置於 E 欄位
Dim SearchStr As String
For U = RngHead.Row + 1 To DataCunt
SearchStr = Trim(Worksheets("工作表1").Cells(U, 4))
If (SearchStr <> "") Then
Worksheets("工作表1").Cells(U, 5) = WorksheetFunction.CountIf(Worksheets("工作表1").Range("D1:D65536"), SearchStr)
End If
Next

'排序:E, D ,B 欄位
Columns("A:E").Select
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Clear
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("工作表1").Sort
.SetRange Range("A1:E" & DataCunt)
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

'產生新格式
Dim OldStr As String
Dim X As Integer
OldStr = ""
X = -1
For U = RngHead.Row + 1 To DataCunt
If (Trim(Worksheets("工作表1").Cells(U, 3)) <> "") Then
If (OldStr = Trim(Worksheets("工作表1").Cells(U, 5))) Then
X = X + 1
Else
If X = -1 Then
X = X + 3
Else
X = X + 4
End If
OldStr = Trim(Worksheets("工作表1").Cells(U, 5))
Worksheets("工作表1").Cells(X - 1, 8) = Trim(Worksheets("工作表1").Cells(U, 5)) & "人小組表"
Worksheets("工作表1").Cells(X, 7) = "隊"
Worksheets("工作表1").Cells(X, 8) = "姓名"
Worksheets("工作表1").Cells(X, 9) = "小組"
End If
Worksheets("工作表1").Cells(X + 1, 7) = Trim(Worksheets("工作表1").Cells(U, 1))
Worksheets("工作表1").Cells(X + 1, 8) = Trim(Worksheets("工作表1").Cells(U, 2))
Worksheets("工作表1").Cells(X + 1, 9) = Trim(Worksheets("工作表1").Cells(U, 3))
End If
Next

'清除暫存:D,E 欄位
Columns("D:E").Select
Selection.ClearContents

End Sub

``````

peterzxcv iT邦新手 5 級 ‧ 2021-05-05 22:37:35 檢舉

1

peterzxcv iT邦新手 5 級 ‧ 2021-05-05 22:39:33 檢舉

rogeryao iT邦大師 2 級 ‧ 2021-05-05 23:11:15 檢舉

peterzxcv iT邦新手 5 級 ‧ 2021-05-05 23:58:58 檢舉
rogeryao iT邦大師 2 級 ‧ 2021-05-06 00:17:24 檢舉

==>有隊,姓名,小組三個欄位,以下都是資料;就像我的貼圖一樣

rogeryao iT邦大師 2 級 ‧ 2021-05-07 15:23:27 檢舉
``````Private Sub CommandButton1_Click()
DataCunt = Worksheets("工作表1").Range("A65536").End(xlUp).Row

'去除重複資料
Columns("A:C").Select
ActiveSheet.Range("\$A\$1:\$C\$" & DataCunt).RemoveDuplicates Columns:=Array(1, 2, 3), _

'刪除 B 欄中的空白行
If WorksheetFunction.CountBlank(Range("B1:B" & DataCunt)) > 0 Then
Columns("B:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If

'檢查第一筆資料
If Cells(1, 2) <> "姓名" Then
MsgBox "第一筆資料須為欄位名稱(隊,姓名,小組)"
Exit Sub
Else
Cells(1, 1) = "隊"
Cells(1, 3) = "小組"
End If

Dim U As Integer

'A,C 合併成 D
For U = RngHead.Row + 1 To DataCunt
If (Trim(Worksheets("工作表1").Cells(U, 3)) <> "") Then
Worksheets("工作表1").Cells(U, 4) = Worksheets("工作表1").Cells(U, 1) & Worksheets("工作表1").Cells(U, 3)
End If
Next

'用 CountIf 計算 D 欄位同一字串出現次數,置於 E 欄位
Dim SearchStr As String
For U = RngHead.Row + 1 To DataCunt
SearchStr = Trim(Worksheets("工作表1").Cells(U, 4))
If (SearchStr <> "") Then
Worksheets("工作表1").Cells(U, 5) = WorksheetFunction.CountIf(Worksheets("工作表1").Range("D1:D65536"), SearchStr)
End If
Next

'排序:E, D ,B 欄位
Columns("A:E").Select
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Clear
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("工作表1").Sort
.SetRange Range("A1:E" & DataCunt)
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

'產生新格式
Dim OldStr As String
Dim X As Integer
OldStr = ""
X = -1
For U = RngHead.Row + 1 To DataCunt
If (Trim(Worksheets("工作表1").Cells(U, 3)) <> "") Then
If (OldStr = Trim(Worksheets("工作表1").Cells(U, 5))) Then
X = X + 1
Else
If X = -1 Then
X = X + 3
Else
X = X + 4
End If
OldStr = Trim(Worksheets("工作表1").Cells(U, 5))
Worksheets("工作表1").Cells(X - 1, 8) = Trim(Worksheets("工作表1").Cells(U, 5)) & "人小組表"
Worksheets("工作表1").Cells(X, 7) = "隊"
Worksheets("工作表1").Cells(X, 8) = "姓名"
Worksheets("工作表1").Cells(X, 9) = "小組"
End If
Worksheets("工作表1").Cells(X + 1, 7) = Trim(Worksheets("工作表1").Cells(U, 1))
Worksheets("工作表1").Cells(X + 1, 8) = Trim(Worksheets("工作表1").Cells(U, 2))
Worksheets("工作表1").Cells(X + 1, 9) = Trim(Worksheets("工作表1").Cells(U, 3))
End If
Next

'清除暫存:D,E 欄位
Columns("D:E").Select
Selection.ClearContents

End Sub
``````
peterzxcv iT邦新手 5 級 ‧ 2021-05-07 22:57:21 檢舉

rogeryao iT邦大師 2 級 ‧ 2021-05-08 10:40:34 檢舉
``````Private Sub CommandButton1_Click()
DataCunt = Worksheets("工作表1").Range("A65536").End(xlUp).Row

'去除重複資料
Columns("A:C").Select
ActiveSheet.Range("\$A\$1:\$C\$" & DataCunt).RemoveDuplicates Columns:=Array(1, 2, 3), _

'刪除 B 欄中的空白行
If WorksheetFunction.CountBlank(Range("B1:B" & DataCunt)) > 0 Then
Columns("B:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End If

'檢查第一筆資料
If Cells(1, 2) <> "姓名" Then
MsgBox "第一筆資料須為欄位名稱(隊,姓名,小組)"
Exit Sub
Else
Cells(1, 1) = "隊"
Cells(1, 3) = "小組"
End If

Dim U As Integer

'用 CountIf 計算 C 欄位同一字串出現次數,置於 D 欄位
Dim SearchStr As String
For U = RngHead.Row + 1 To DataCunt
SearchStr = Trim(Worksheets("工作表1").Cells(U, 3))
If (SearchStr <> "") Then
Worksheets("工作表1").Cells(U, 4) = WorksheetFunction.CountIf(Worksheets("工作表1").Range("C1:C65536"), SearchStr)
End If
Next

'排序:D,C,A,B 欄位
Columns("A:D").Select
ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Clear
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("工作表1").Sort
.SetRange Range("A1:D" & DataCunt)
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

'產生新格式
Dim OldStr As String
Dim X As Integer
OldStr = ""
X = -1
For U = RngHead.Row + 1 To DataCunt
If (Trim(Worksheets("工作表1").Cells(U, 3)) <> "") Then
If (OldStr = Trim(Worksheets("工作表1").Cells(U, 4))) Then
X = X + 1
Else
If X = -1 Then
X = X + 3
Else
X = X + 4
End If
OldStr = Trim(Worksheets("工作表1").Cells(U, 4))
Worksheets("工作表1").Cells(X - 1, 8) = Trim(Worksheets("工作表1").Cells(U, 4)) & "人小組表"
Worksheets("工作表1").Cells(X, 7) = "隊"
Worksheets("工作表1").Cells(X, 8) = "姓名"
Worksheets("工作表1").Cells(X, 9) = "小組"
End If
Worksheets("工作表1").Cells(X + 1, 7) = Trim(Worksheets("工作表1").Cells(U, 1))
Worksheets("工作表1").Cells(X + 1, 8) = Trim(Worksheets("工作表1").Cells(U, 2))
Worksheets("工作表1").Cells(X + 1, 9) = Trim(Worksheets("工作表1").Cells(U, 3))
End If
Next

'清除暫存:D 欄位
Columns("D:D").Select
Selection.ClearContents

End Sub
``````
0

iT邦大師 1 級 ‧ 2021-05-05 12:39:38

peterzxcv iT邦新手 5 級 ‧ 2021-05-05 13:37:08 檢舉

1

iT邦大神 1 級 ‧ 2021-05-05 16:25:05

1.輸入 Sheet1 資料
2.執行 MainLoop
3.結果在 Sheet2,Sheet3,Sheet4 三張工作表

``````Type Student
Seq As String
Name As String
Group As String
End Type
Sub MainLoop()
Dim person As Student
Dim arr() As Student

bFirst = True
R = 2

savedGroup = ""

Range("A1:C1000").Sort Key1:=Range("C2"), Order1:=xlDescending, Key2:=Range _
("A2"), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase _
:=False, Orientation:=xlTopToBottom, SortMethod:=xlStroke, DataOption1:= _
xlSortNormal, DataOption2:=xlSortNormal

Do While Worksheets("Sheet1").Cells(R, 3) <> ""

If bFirst = True Then
savedGroup = Worksheets("Sheet1").Cells(R, 3)

person.Seq = Worksheets("Sheet1").Cells(R, 1)
person.Name = Worksheets("Sheet1").Cells(R, 2)
person.Group = Worksheets("Sheet1").Cells(R, 3)

ReDim arr(1)
arr(1) = person

bFirst = False
Else
If Worksheets("Sheet1").Cells(R, 3) = savedGroup Then
person.Seq = Worksheets("Sheet1").Cells(R, 1)
person.Name = Worksheets("Sheet1").Cells(R, 2)
person.Group = Worksheets("Sheet1").Cells(R, 3)

ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr)) = person
Else

savedGroup = Worksheets("Sheet1").Cells(R, 3)

person.Seq = Worksheets("Sheet1").Cells(R, 1)
person.Name = Worksheets("Sheet1").Cells(R, 2)
person.Group = Worksheets("Sheet1").Cells(R, 3)

ReDim arr(1)
arr(1) = person
End If
End If

R = R + 1
Loop

End Sub
Dim onerow As Student

sheetName = "Sheet" & UBound(pArr)
R = Range(sheetName & "!A65536").End(xlUp).Row + 1

For nI = 1 To UBound(pArr)
onerow = pArr(nI)
Worksheets(sheetName).Cells(R + (nI - 1), 1) = onerow.Seq
Worksheets(sheetName).Cells(R + (nI - 1), 2) = onerow.Name
Worksheets(sheetName).Cells(R + (nI - 1), 3) = onerow.Group
Next nI

End Sub
``````

peterzxcv iT邦新手 5 級 ‧ 2021-05-05 20:34:49 檢舉

1.確認有四張工作表 Sheet1, Sheet2, Sheet3, Sheet4
2.點偵錯按鈕，看看錯在那一列程式碼

peterzxcv iT邦新手 5 級 ‧ 2021-05-05 22:41:00 檢舉

peterzxcv iT邦新手 5 級 ‧ 2021-05-05 22:42:32 檢舉

1.我不想下載你的原檔
2.我改了一點程式，更新在回答中
3.放上 Sheet1 的資料和 Sheet2,Sheet3,Sheet4 的執行結果供參考
4.如果還是錯就另請高明

peterzxcv iT邦新手 5 級 ‧ 2021-05-11 14:29:25 檢舉