推 ljuber:感謝^^ 不過我同事的檔案要求所有(連保護)也copy過去 04/29 16:51
→ ljuber:感覺很困難 先算了 不過很感謝大大 這巨集很好用的說^^ 04/29 16:52
如果只是要處理，可以先用這個，不過合併儲存格會沒有資料就是了 ...
Option Explicit
Sub Macro1()
Dim rCount As Integer
Dim curdir As String
Dim i As Integer, j As Integer, rc 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
Set wbNew = Workbooks.Add
.Range(rangeStr).EntireRow.Copy
rc = wbNew.Sheets(1).Range("A1").CurrentRegion.Rows.Count
wbNew.Sheets(1).Range("A" & rc).PasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
rangeStr = i & ":" & i
.Range(rangeStr).EntireRow.Copy
rc = wbNew.Sheets(1).Range("A1").CurrentRegion.Rows.Count + 1
wbNew.Sheets(1).Range("A" & rc).PasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
For j = i + 1 To rCount '將相同名稱的串起來
If (flag(j) = False) And (.Cells(i, 1) = .Cells(j, 1)) Then
rangeStr = j & ":" & j
.Range(rangeStr).EntireRow.Copy
rc = wbNew.Sheets(1).Range("A1").CurrentRegion.Rows.Count + 1
wbNew.Sheets(1).Range("A" & rc).PasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
flag(j) = True
End If
Next j
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
※ 引述《windknife18 (windknife18)》之銘言：
: 剛才看了一下，才發現前一個回答，是拿中間 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 (給你吃膨餅)》之銘言：
: : 如果是說 要連儲存格裡面有公式的也一起貼過去
: : 這有辦法嗎???XD
: : 好像要求有點多 哈XD
--
※ 發信站: 批踢踢實業坊(ptt.cc)
◆ From: 140.131.84.79