iT邦幫忙

0

EXCEL VBA 分組導出各類組求解

https://ithelp.ithome.com.tw/upload/images/20210507/20120368gvZKvnsUYG.jpg
https://www.mediafire.com/file/sx4bgut2mrfkv3r/VBMS.xlsx/file
請求各位專家幫忙,A欄為大隊,C欄為成員2.3.4人一組之組號(組號可為中英文數字),導出為全隊分組表:2人組、3人組、4人組,以大隊排序為優先,組號為輔

1.16筆是「固定」的嗎?
2.會有「4x4」或「3x4+2x2」或「2x8」這種分組法嗎?
peterzxcv iT邦新手 5 級 ‧ 2021-05-05 14:39:12 檢舉
1.不是只固定16格的,讓成員填寫為a4表格基本會42格,基本會少於所以有表格沒序號,另外會在空個幾行又接續下一張表格
2.基本只看同組號就放一起,導出的表我也是用a4的表,大大寫的分法不是很清楚
0
rogeryao
iT邦大師 2 級 ‧ 2021-05-05 16:01:14
最佳解答
Private Sub CommandButton1_Click()
Dim U As Integer
Set RngHead = Worksheets("工作表1").Range("C1")
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
ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Add2 Key:=Range("D2:D" & DataCunt), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Add2 Key:=Range("A2:A" & DataCunt), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("工作表1").Sort
    .SetRange Range("A1:D" & DataCunt)
    .Header = xlYes
    .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

https://ithelp.ithome.com.tw/upload/images/20210505/20085021XxnkNFgi4x.png

https://ithelp.ithome.com.tw/upload/images/20210505/200850215BdbDHzQO8.png

看更多先前的回應...收起先前的回應...
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
Set RngHead = Worksheets("工作表1").Range("C1")
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
ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Add2 Key:=Range("E2:E" & DataCunt), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Add2 Key:=Range("D2:D" & DataCunt), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Add2 Key:=Range("B2:B" & DataCunt), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("工作表1").Sort
    .SetRange Range("A1:E" & DataCunt)
    .Header = xlYes
    .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

https://ithelp.ithome.com.tw/upload/images/20210505/20085021rXBoL6e469.png

https://ithelp.ithome.com.tw/upload/images/20210505/20085021MfQ9CDhirS.png

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 檢舉

程式碼已更新 , 主要修改 '排序:E, D ,B 欄位

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

我測試是正確的,最好先把 excel 整理好
==>有隊,姓名,小組三個欄位,以下都是資料;就像我的貼圖一樣

混亂的資料極可能產生不如預期的結果

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), _
    Header:=xlNo

'刪除 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
Set RngHead = Worksheets("工作表1").Range("C1")

'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
ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Add2 Key:=Range("E2:E" & DataCunt), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Add2 Key:=Range("D2:D" & DataCunt), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Add2 Key:=Range("B2:B" & DataCunt), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("工作表1").Sort
    .SetRange Range("A1:E" & DataCunt)
    .Header = xlYes
    .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 檢舉

https://ithelp.ithome.com.tw/upload/images/20210507/20120368a7FgXSKCpV.jpg
各顏色代表本該相同組,分拆判斷異常
是希望同組都一起,但排序依大隊順序

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), _
    Header:=xlNo

'刪除 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
Set RngHead = Worksheets("工作表1").Range("C1")

'用 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
ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Add2 Key:=Range("D2:D" & DataCunt) _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Add2 Key:=Range("C2:C" & DataCunt) _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Add2 Key:=Range("A2:A" & DataCunt) _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("工作表1").Sort.SortFields.Add2 Key:=Range("B2:B" & DataCunt) _
    , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("工作表1").Sort
    .SetRange Range("A1:D" & DataCunt)
    .Header = xlYes
    .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
                Call AddRowSheet(arr)
                
                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
    
    Call AddRowSheet(arr)
End Sub
Sub AddRowSheet(pArr() As Student)
    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

https://ithelp.ithome.com.tw/upload/images/20210506/20001787DmAUqgBe2v.png
https://ithelp.ithome.com.tw/upload/images/20210506/20001787j6zJKS4pUR.png
https://ithelp.ithome.com.tw/upload/images/20210506/20001787zD5zmXRT1f.png
https://ithelp.ithome.com.tw/upload/images/20210506/20001787Ap96NqiusK.png

看更多先前的回應...收起先前的回應...
peterzxcv iT邦新手 5 級 ‧ 2021-05-05 20:34:49 檢舉

動不了,不知甚麼問題https://ithelp.ithome.com.tw/upload/images/20210505/20120368WuDTm3Vqiw.jpg

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

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

之前sheet中英文會有差異我沒注意,還有要先新增Sheet2,Sheet3,Sheet4 才會正常運行

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 檢舉

程式是可運行的,謝謝

我要發表回答

立即登入回答