EXCEL 活頁簿SHEET1資料分至不同活頁簿

mariabb

可否不用VBA, 只用函數或巨集處理下列 ?
(1)
請問有檔案內SHEET1, 內有30名員工資料 (是從人事系統輸出的資料), 已固定每10 ROW為一個員工的資料, 如何將之一次過, 分別儲存至30個不同的EXCEL獨立檔.
即檔案A是陳大文的資料 (來源是活頁簿SHEET1 A1:Z10)
檔案B是李小花的資料 (來源是活頁簿SHEET1 A11:Z21), 如此類推.

(2) 又如何可以快速為每個或一次過將所有獨立檔案:
2A)設定活頁簿防護密碼, 及
2B) 設定檔案開啟密碼?
多謝!

sunnyso

回復 1# mariabb

不用VBA無法做到

mariabb

那麼, 可否請教VBA如何做呢, 我現正開始學習.

genes

每一活頁簿是一個EXCEL獨立檔

1. Sub SplitWorkbook()
   
2. Dim ws As Worksheet
   
3. Dim DisplayStatusBar As Boolean
   
4. DisplayStatusBar = Application.DisplayStatusBar
   
5. Application.DisplayStatusBar = True
   
6. Application.ScreenUpdating = False
   
7. Application.DisplayAlerts = False
   
8. For Each ws In ThisWorkbook.Sheets
   
9. Dim NewFileName As String
   
10. Application.StatusBar = ThisWorkbook.Sheets.Count & “ Remaining Sheets”
    
11. If ThisWorkbook.Sheets.Count <> 1 Then
    
12. NewFileName = ThisWorkbook.Path & “\” & ws.Name & “.xlsm” ‘Macro _
    
13. -Enabled
    
14. ‘ NewFileName = ThisWorkbook.Path & “\” & ws.Name & “.xlsx” _
    
15. ‘Not Macro-Enabled
    
16. ws.Copy
    
17. ActiveWorkbook.Sheets(1).Name = “Sheet1”
    
18. ActiveWorkbook.SaveAs Filename:=NewFileName, _
    
19. FileFormat:=xlOpenXMLWorkbookMacroEnabled
    
20. ‘ ActiveWorkbook.SaveAs Filename:=NewFileName, _
    
21. FileFormat:=xlOpenXMLWorkbook
    
22. ActiveWorkbook.Close SaveChanges:=False
    
23. Else
    
24. NewFileName = ThisWorkbook.Path & “\” & ws.Name & “.xlsm”
    
25. ‘ NewFileName = ThisWorkbook.Path & “\” & ws.Name & “.xlsx”
    
26. ws.Name = “Sheet1”
    
27. End If
    
28. Next
    
29. Application.DisplayAlerts = True
    
30. Application.StatusBar = False
    
31. Application.DisplayStatusBar = DisplayStatusBar
    
32. Application.ScreenUpdating = True
    
33. End Sub

複製代碼

mhl9mhl9

回復 1# mariabb

輸出新文件名=A1.xlsm,A11.xlsm,A21.xlsm,A31...
workbook password=123456
workbook open password=123456
workbook 儲存在 thisworkbook所在folder里

Sub CreatePrivateWB()
    Do
        Set R = Cells(1, 1).Offset(10 * p).Resize(10, 26)
        A = R.Value
        If WorksheetFunction.CountA(A) > 0 Then
            R.Copy
            Set Wb = Workbooks.Add
            With Wb
                Name = R.Cells(1).Address(False, False, xlA1)
                Cells(1, 1).PasteSpecial
                .Protect 123456
                .SaveAs Filename:=ThisWorkbook.Path & "\" & Name & ".xlsm", _
                FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:=123456
                .Close True
            End With
            p = p + 1
        Else
            Exit Sub
        End If
    Loop
End Sub