作者windknife18 (windknife18)
看板Office
標題Re: [算表] 將特定條件的儲存格輸出成多個檔案--VBA
時間Tue Apr 28 13:56:27 2009
剛才看了一下，才發現前一個回答，是拿中間 wengo 問的程式來改說，
原來是改錯了說 ^_^
重新用之前的檔案修改成你要的囉，看看有無問題！
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
wbNew.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
wbNew.Sheets(1).Cells(1, 1).Select
wbNew.Close SaveChanges:=True, Filename:=curdir & .Cells(i, 1) & ".xls"
End If
Next i
End With
Sheets(1).Select
Cells(1, 1).Select
Application.CutCopyMode = False
MsgBox ("成功")
End Sub
※ 引述《ljuber (給你吃膨餅)》之銘言：
: ※ 引述《windknife18 (windknife18)》之銘言：
: 如果是說 要連儲存格裡面有公式的也一起貼過去
: 這有辦法嗎???XD
: 好像要求有點多 哈XD
--
※ 發信站: 批踢踢實業坊(ptt.cc)
◆ From: 61.229.72.161
→ windknife18:打錯了，不是 wengo 是 wengho 說，針對不起 wengho 04/28 13:59
推 ljuber:太感謝了~~~~等下來實驗看看^^ 04/28 15:10
→ windknife18:^^ 04/29 09:45
推 ljuber:.Range(rangeStr).EntireRow.Copy 這段有問題XD 04/29 14:35
→ windknife18:剛再run了一次沒有問題阿 04/29 14:42
推 ljuber:他是出現執行階段錯誤 無法改變合併儲存格的一部分 04/29 15:10
→ windknife18:你有使用合併儲存格？？ 04/29 15:11
推 ljuber:似乎儲存格有合併的會失敗XD 04/29 15:12
→ ljuber:因為我同事弄的表格 合併一堆東西XD 04/29 15:13
→ windknife18:因為通常有何並儲存格，會造成copy用range的時候發生 04/29 15:17
→ windknife18:問題，而且如果有合併，在copy的時候只有第一列有資料 04/29 15:18
→ ljuber:了解:) 是否有解決方式XD 04/29 15:18
推 wengho:大大別客氣了!其實你真的很厲害.那段程式省了超多時間. 04/29 20:08
→ wengho:除了感謝還是感謝^_^ 04/29 20:09