根据表格中的内容，快速拆分成单独的Excel

我有50家水果店（要是真的就好了^_^），每家有不同种类的水果及数量。我有一份进货的明细表，需要下发到各水果店核查入库数量是否正确。

那现在进货的明细表如下：

​需要生成50个Excel表，每个表只显示自己店铺的货量。

操作步骤如下：

第一步：按照店铺类型，生成不同的sheet。

打开Excel，按住 ALT + F11，调出VBA窗口。

好吧，没找到Pyhon代码，先用VBA干活吧。

单击【插入】，【模块】，复制如下代码。

Sub Splitdatabycol()'updateby ExtendofficeDim lr As LongDim ws As WorksheetDim vcol, i As IntegerDim icol As LongDim myarr As VariantDim title As StringDim titlerow As IntegerDim xTRg As RangeDim xVRg As RangeDim xWSTRg As WorksheetOn Error Resume NextSet xTRg = Application.InputBox("Please select the header rows:", "Kutools for Excel", "", Type:=8)If TypeName(xTRg) = "Nothing" Then Exit SubSet xVRg = Application.InputBox("Please select the column you want to split data based on:", "Kutools for Excel", "", Type:=8)If TypeName(xVRg) = "Nothing" Then Exit Subvcol = xVRg.ColumnSet ws = xTRg.Worksheetlr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Rowtitle = xTRg.AddressLocaltitlerow = xTRg.Cells(1).Rowicol = ws.Columns.Countws.Cells(1, icol) = "Unique"Application.DisplayAlerts = FalseIf Not Evaluate("=ISREF('xTRgWs_Sheet!A1')") ThenSheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"ElseSheets("xTRgWs_Sheet").DeleteSheets.Add(after:=Worksheets(Worksheets.Count)).Name = "xTRgWs_Sheet"End IfSet xWSTRg = Sheets("xTRgWs_Sheet")xTRg.CopyxWSTRg.Paste Destination:=xWSTRg.Range("A1")ws.ActivateFor i = (titlerow + xTRg.Rows.Count) To lrOn Error Resume NextIf ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Thenws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)End IfNextmyarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))ws.Columns(icol).ClearFor i = 2 To UBound(myarr)ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") ThenSheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""ElseSheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)End IfxWSTRg.Range(title).CopySheets(myarr(i) & "").Paste Destination:=Sheets(myarr(i) & "").Range("A1")ws.Range("A" & (titlerow + xTRg.Rows.Count) & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A" & (titlerow + xTRg.Rows.Count))Sheets(myarr(i) & "").Columns.AutoFitNextxWSTRg.Deletews.AutoFilterMode = Falsews.ActivateApplication.DisplayAlerts = TrueEnd Sub

​然后按下F5，运行。

回到Excel，选择标题行，单击确定。

再选择要拆分内容的单元格，这里是A2到A5，单击确定。

可以看到，多了3个sheet。

第二步：导出sheet到单独的Excel。​

再插入一个模块，复制代码后，单击F5。

这里要注意下，Excel会导出到当前Excel所在的路径。建议导出之前将Excel放到一个文件夹中，然后再执行代码。

Sub Splitbook()'Updateby20140612Dim xPath As StringxPath = Application.ActiveWorkbook.PathApplication.ScreenUpdating = FalseApplication.DisplayAlerts = FalseFor Each xWs In ThisWorkbook.SheetsxWs.Copy    Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xlsx"    Application.ActiveWorkbook.Close FalseNextApplication.DisplayAlerts = TrueApplication.ScreenUpdating = TrueEnd Sub

结果如下：

以上！