推 wengho:謝謝大大 禮拜一去公司試看看 感恩^^ 04/25 13:22
看看是不是你想要的囉 ....
Option Explicit
Sub Macro1()
Dim i As Integer, j As Integer, rCount As Integer
Dim firstr As Integer, lastr As Integer
Dim rangeStr As String
'不要問要不要覆蓋檔案
Application.DisplayAlerts = False
'先清掉其他 sheets
For i = ThisWorkbook.Sheets.Count To 2 Step -1
ThisWorkbook.Sheets(i).Delete
Next i
With ThisWorkbook
'計算多少筆資料
rCount = Sheets(1).Cells(Sheets(1).Rows.Count, 1).End(xlUp).Row
i = 2
While i <= rCount '處理每一筆資料
j = i + 1
rangeStr = "1:1"
'找出相同的資料
While (Sheets(1).Cells(j, 1) = Sheets(1).Cells(i, 1)) _
And (j <= rCount)
j = j + 1
Wend
If (j = rCount + 1) Then
rangeStr = rangeStr & "," & i & ":" & j
Else
rangeStr = rangeStr & "," & i & ":" & (j - 1)
End If
.Sheets.Add After:=Sheets(Sheets.Count)
.Sheets(Sheets.Count).Name = .Sheets(1).Cells(i, 1)
.Sheets(1).Range(rangeStr).EntireRow.Copy _
Destination:=Sheets(Sheets.Count).Range("A1")
i = j
Wend
End With
MsgBox ("成功")
End Sub
※ 引述《wengho (wengho)》之銘言：
: 請教一個延伸問題
: 譬如這個檔案
: 已經做過排序
: 如下:
: 科別 機構 A科目 B科目 C科目 ........
: 一科 A
: 一科 B
: 一科 E
: 一科 F
: 二科 C
: 二科 D
: 南辦 G
: 南辦 H
: 這一回所輸出的資料是同一個檔案 "更改sheet工作表名稱" 並把資料COPY分類置個科別
: 如:總表.XLS
: 總表 一科 二科 南辦 …
: 點選"一科"工作表
: 內容就變成
: 科別 機構 A科目 B科目 C科目 ........
: 一科 A
: 一科 B
: 一科 E
: 一科 F
: 點選"二科"工作表
: 內容就變成
: 科別 機構 A科目 B科目 C科目 ........
: 二科 C
: 二科 D
: 依此類推......
: 再次感謝網友大大們的協助^^
--
※ 發信站: 批踢踢實業坊(ptt.cc)
◆ From: 140.131.84.79