作者windknife18 (windknife18)
看板Office
標題Re: [算表] 將特定條件的儲存格輸出成多個檔案--VBA
時間Fri Apr 24 22:17:08 2009
順便簡化程式以及加一點註解囉
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
推 ljuber:真厲害～我在來研究看看^^ 04/24 22:41
推 ljuber:Destination:=wbNew.Sheets(1).Range("A1") 這行有問題? 04/24 22:48
→ windknife18:這一行跟前一行是在一起的說，貼過來變成兩行了 XD 04/24 23:01
推 ljuber:了解! 04/24 23:02
推 ljuber:成功了！ 太感謝了!!!!!!! 04/24 23:07
→ ljuber:這巨集我相信版上的朋友應該會有很多有需要^^ 04/24 23:08
→ windknife18:^^ 04/24 23:09
→ ljuber:如果我標題的range是有好幾列 要改哪邊? 04/24 23:13
→ windknife18:假設三列的話 For i = 2 To rCount 改成 04/24 23:19
→ windknife18:For i = 4 To rCount 04/24 23:19
推 ljuber:感謝 我再實驗看看^^ 04/24 23:21
→ windknife18:rangeStr = "1:1" 改成 rangeStr="1:3" 即可 04/24 23:22
推 ljuber:那只要改rangeStr="1:1"這邊就可以了囉? 04/24 23:34
→ windknife18:兩邊要一起改，這是互相配合的 ^_^ 04/24 23:37
→ windknife18:你剛才太快實驗，我還沒有全部打完說 ^_^ 04/24 23:38
推 wengho:這個程式分類很快速 讚! 04/25 05:48