iT邦幫忙

1

EXCEL VBA 分組導出各類組求解

excel vba #excel #vba vba
peterzxcv 2021-05-05 11:32:52 ‧ 2925 瀏覽

  • 分享至 

  • xImage

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人組，以大隊排序為優先，組號為輔

海綿寶寶 iT邦大神 1 級 ‧ 2021-05-05 14:04:58 檢舉
1.16筆是「固定」的嗎？
2.會有「4x4」或「3x4+2x2」或「2x8」這種分組法嗎？
peterzxcv iT邦新手 5 級 ‧ 2021-05-05 14:39:12 檢舉
1.不是只固定16格的，讓成員填寫為a4表格基本會42格，基本會少於所以有表格沒序號，另外會在空個幾行又接續下一張表格
2.基本只看同組號就放一起，導出的表我也是用a4的表，大大寫的分法不是很清楚
登入發表討論
圖片
  直播研討會
圖片
{{ item.channelVendor }} {{ item.webinarstarted }} |
{{ formatDate(item.duration) }}
直播中

3 個回答

0
rogeryao
iT邦超人 7 級 ‧ 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邦超人 7 級 ‧ 2021-05-05 20:38:55 檢舉

比較簡單的作法,在小組代號前加一碼 :
1B1 : 第一隊B1
2B1 : 第二隊B1

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

我有修改圖表，我的序搞錯了是要用隊才是，組比較不好動

rogeryao iT邦超人 7 級 ‧ 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邦超人 7 級 ‧ 2021-05-05 23:11:15 檢舉

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

peterzxcv iT邦新手 5 級 ‧ 2021-05-05 23:58:58 檢舉

https://www.mediafire.com/file/t7zu05ddbhwfu77/VBMS.xlsx/file
檔案跑還是切割異常

rogeryao iT邦超人 7 級 ‧ 2021-05-06 00:17:24 檢舉

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

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

rogeryao iT邦超人 7 級 ‧ 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邦超人 7 級 ‧ 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 檢舉

是希望能將左表產出右邊樣式表

登入發表回應
2
海綿寶寶
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

海綿寶寶 iT邦大神 1 級 ‧ 2021-05-05 22:35:16 檢舉

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

我上傳原檔可以試試
https://www.mediafire.com/file/t7zu05ddbhwfu77/VBMS.xlsx/file

海綿寶寶 iT邦大神 1 級 ‧ 2021-05-06 08:18:08 檢舉

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

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

程式是可運行的，謝謝

megabox iT邦新手 5 級 ‧ 2022-12-20 20:21:53 檢舉

請問語法有得調整成在同一工作表不同欄列嗎，參照主題擬定如圖所示，謝謝
https://ithelp.ithome.com.tw/upload/images/20221220/20156191gfJuwf96Qs.jpg

登入發表回應

我要發表回答

立即登入回答
iThome鐵人賽
參賽組數
1064 組
團體組數
40 組
累計文章數
22195 篇
完賽人數
600 人
iT+看影片追技術 看影片追技術 看更多
熱門tag 看更多
15th鐵人賽 16th鐵人賽 13th鐵人賽 14th鐵人賽 12th鐵人賽 11th鐵人賽 鐵人賽 2019鐵人賽 javascript 2018鐵人賽 python 2017鐵人賽 windows php c# windows server linux css react vue.js
熱門問題
熱門回答
熱門文章
IT邦幫忙