Re: [算表] 將特定條件的儲存格輸出成多個檔案--VBA

[windknife18 (windknife18)]

不會阿，修改一下就可以符合你的需求，和樂而不為呢 ^_^

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
        '主要是這二行
        Sheets(Sheets.Count).Range("A1").PasteSpecial Paste:=xlPasteAll, _
        Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        i = j
      Wend
    End With
    ThisWorkbook.Sheets(1).Select
    Cells(1, 1).Select
    Application.CutCopyMode = False
    MsgBox ("成功")
End Sub


※ 引述《ljuber (給你吃膨餅)》之銘言：
: ※ 引述《windknife18 (windknife18)》之銘言：
:  如果是說 要連儲存格裡面有公式的也一起貼過去
:  這有辦法嗎???XD
:  好像要求有點多 哈XD

--
※ 發信站: 批踢踢實業坊(ptt.cc) 
◆ From: 140.131.84.79
推 ljuber:厲害!
→ windknife18:^^
推 ljuber:如果是改 9412篇 輸出成檔案的要怎麼改?
→ windknife18:要不要練習改看看呢？ 差別沒有很大 ...
推 ljuber:VBA幾乎不太懂XD 不過是否要用類似指令?
→ windknife18:只要將輸出的地方修改即可，如果真的沒辦法改，
→ windknife18:沒天下午我有空在改囉 ...
推 ljuber:OK 不然我等你 太感謝了^^