Re: [算表] 將特定條件的儲存格輸出成多個檔案--VBA
順便簡化程式以及加一點註解囉
Option Explicit
Sub Macro1()
Dim rCount As Integer
Dim curdir As String
Dim i As Integer, j As Integer
Dim wbNew As Workbook
Dim flag() As Boolean
Dim rangeStr As String
'不要問要不要覆蓋檔案
Application.DisplayAlerts = False
curdir = ThisWorkbook.Path & Application.PathSeparator
With ThisWorkbook.Sheets(1)
'計算多少筆資料
rCount = .Cells(.Rows.Count, 1).End(xlUp).Row
ReDim flag(rCount)
For i = 2 To rCount
rangeStr = "1:1"
If flag(i) = False Then '檢查是否有處理過
flag(i) = True
rangeStr = rangeStr & "," & i & ":" & i
For j = i + 1 To rCount '將相同名稱的串起來
If (flag(j) = False) And (Cells(i, 1) = Cells(j, 1)) Then
rangeStr = rangeStr & "," & j & ":" & j
flag(j) = True
End If
Next j
Set wbNew = Workbooks.Add
.Range(rangeStr).EntireRow.Copy
Destination:=wbNew.Sheets(1).Range("A1")
wbNew.Close SaveChanges:=True, Filename:=curdir & .Cells(i, 1) & ".xls"
End If
Next i
End With
MsgBox ("成功")
End Sub
※ 引述《ljuber (給你吃膨餅)》之銘言：
: ※ 引述《windknife18 (windknife18)》之銘言：
: : 請看看合不合用囉 ...
: : Option Explicit
: : Sub Macro1()
: : Dim rLastCell As Range
: : Dim strName As String
: : Dim lLoop As Long
: : Dim wbNew As Workbook
: : With ThisWorkbook.Sheets(1)
: : Set rLastCell = .Cells.Find(What:="*", After:=[A1], _
: : SearchDirection:=xlPrevious)
: : For lLoop = 2 To rLastCell.Row
: : Set wbNew = Workbooks.Add
: : .Range("1:1," & lLoop & ":" & lLoop).EntireRow.Copy _
: : Destination:=wbNew.Sheets(1).Range("A1")
: : wbNew.Close SaveChanges:=True, Filename:=ThisWorkbook.Path _
: : & Application.PathSeparator & .Cells(lLoop, 1) & ".xls"
: : Next lLoop
: : End With
: : End Sub
: 感謝大大的幫忙:)
: 不過我發現我測試的時候
: 我要的可能是
: 科別 機構 A科目 B科目 C科目 ........
: 一科 A
: 一科 B
: 二科 C
: 二科 D
: 一科 E
: 一科 F
: 南辦 G
: 南辦 H
: 主要要把科別集中 並且以各科別為檔名
: 例如 輸出成 一科.xls
: 內容就是
: 科別 機構 A科目 B科目 C科目 ........
: 一科 A
: 一科 B
: 一科 E
: 一科 F
: 其他依此類推 希望大大幫忙看看:)
--
※ 發信站: 批踢踢實業坊(ptt.cc)
◆ From: 61.229.73.198
推
04/24 22:41, , 1F
04/24 22:41, 1F
推
04/24 22:48, , 2F
04/24 22:48, 2F
→
04/24 23:01, , 3F
04/24 23:01, 3F
推
04/24 23:02, , 4F
04/24 23:02, 4F
推
04/24 23:07, , 5F
04/24 23:07, 5F
→
04/24 23:08, , 6F
04/24 23:08, 6F
→
04/24 23:09, , 7F
04/24 23:09, 7F
→
04/24 23:13, , 8F
04/24 23:13, 8F
→
04/24 23:19, , 9F
04/24 23:19, 9F
→
04/24 23:19, , 10F
04/24 23:19, 10F
推
04/24 23:21, , 11F
04/24 23:21, 11F
→
04/24 23:22, , 12F
04/24 23:22, 12F
推
04/24 23:34, , 13F
04/24 23:34, 13F
→
04/24 23:37, , 14F
04/24 23:37, 14F
→
04/24 23:38, , 15F
04/24 23:38, 15F
推
04/25 05:48, , 16F
04/25 05:48, 16F
討論串 (同標題文章)
本文引述了以下文章的的內容：
完整討論串 (本文為第 4 之 12 篇)：
Office 近期熱門文章
PTT數位生活區 即時熱門文章
