將工作表某些列存到該列中某欄對應的工作表

依照第7欄的內容建立新資料表

Sub 按鈕1_Click()

'不可有同名的資料表

'新表標題列外的資料起始列(其實目前只有一列標題列ㄎㄎ，還不處理複數列標題)

srow = 2

newsheet_current_row = srow

'依照第幾欄分表

new_sheet_by_col = 7

'資料表名稱

datasheetname = "data"

'資料表最大寬度

max_cols = ActiveSheet.UsedRange.Columns.Count

For i = srow To ActiveSheet.UsedRange.Rows.Count

If Cells(i, new_sheet_by_col) <> Cells(i - 1, new_sheet_by_col) Then

ActiveWorkbook.Sheets.Add.Name = Cells(i, new_sheet_by_col)

Worksheets(datasheetname).Activate

For j = 1 To max_cols

Worksheets(Cells(i, new_sheet_by_col).Text).Cells(1, j) = ActiveSheet.Cells(1, j)

Next

newsheet_current_row = srow

End If

For j = 1 To max_cols

Worksheets(Cells(i, new_sheet_by_col).Text).Cells(newsheet_current_row, j) = ActiveSheet.Cells(i, j)

Next

newsheet_current_row = newsheet_current_row + 1

Next

End Sub

每個工作表存成一個檔案 程式碼來源https://www.extendoffice.com/documents/excel/zh-tw-excel/2856-excel-split-workbook.html

Sub 按鈕1_Click()

  Dim xPath As String

  xPath = Application.ActiveWorkbook.Path

  Application.ScreenUpdating = False

  Application.DisplayAlerts = False

  For Each xWs In ThisWorkbook.Sheets

      xWs.Copy

      Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx" 'xls or xlsx?

      Application.ActiveWorkbook.Close False

  Next

  Application.DisplayAlerts = True

  Application.ScreenUpdating = True

End Sub

tmp