以下代码为工作中的真实案例（不是真实数据~~~），本人是销售方，每季度都要和关联方进行对账，这工作量大的可怕估计有五六十家关联方，我又不能把所有数据都发送给关联方，最好是根据每个关联方的名字来进行筛选，然后将交易、往来、现金流三个表格的数据发送给对方。这样每家就只能看到每家的数据，我也不用重复做工作，筛选然后复制，要新建60个工作表，每家要粘贴三遍，那就是180遍~~我感觉我几天就没有了~~~
为了增加我工作效率，我研究了一晚上，写了以下代码。
新建一个excel，在sheet1里A列列明要查找的单位名称，C列则用来对新建的excel命名，用于区分是服务还是生产类公司。sheet2里复制粘贴“交易”数据，sheet3复制粘贴“往来”数据，sheet4“复制粘贴现金流”数据。在sheet1里新建了一个commandbutton。输入以下代码。
Private Sub CommandButton1_Click()Dim iPath$, ifilename$, iName$, ibook As WorkbookDim i, nDim myNewWorkbook As Integer ' 定义新workbook为整数Dim shname As Variant
以上为定义各个变量
For n = 2 To Application.WorksheetFunction.CountA(Range("A:A"))
此句为设定n为2到a列最后一个非空单元格的行数
ifilename = Sheet1.Cells(n, 3)
将sheet1里c列的单元值赋值给新建工作簿名字
shname = Array("交易", "往来", "现金流")myNewWorkbook = Application.SheetsInNewWorkbook '新生成的工作簿里面的sheetApplication.SheetsInNewWorkbook = 3 '定义新工作簿里有3个sheetSet ibook = Workbooks.Add '新增一个worksheetWith ibookFor i = 1 To 3With .Sheets(i).name = shname(i - 1)End WithNext i '将三个工作sheet命名到新workbook中
将交易往来现金流赋值给shname
定义新的工作簿里有三张工作表
新增一个工作表
定义i从1到3
此过程为实现新建个工作簿按照c列命名，并建立三张工作表，分别命名为交易、往来、现金流
ThisWorkbook.ActivateiName = ThisWorkbook.Sheets(1).Cells(n, 1)ActiveWorkbook.Sheets(2).SelectWith Selection.AutoFilter.AutoFilter field:=6, Criteria1:=iName.CurrentRegion.Select.SpecialCells(xlCellTypeVisible).CopyEnd With.Sheets(1).Range("A1").PasteSpecial xlPasteColumnWidths.Sheets(1).Range("A1").PasteSpecial xlPasteAllThisWorkbook.ActivateiName = ThisWorkbook.Sheets(1).Cells(n, 1)ActiveWorkbook.Sheets(3).SelectWith Selection.AutoFilter.AutoFilter field:=6, Criteria1:=iName.CurrentRegion.Select.SpecialCells(xlCellTypeVisible).CopyEnd With.Sheets(2).Range("A1").PasteSpecial xlPasteColumnWidths.Sheets(2).Range("A1").PasteSpecial xlPasteAllThisWorkbook.ActivateiName = ThisWorkbook.Sheets(1).Cells(n, 1)ActiveWorkbook.Sheets(4).SelectWith Selection.AutoFilter.AutoFilter field:=5, Criteria1:=iName.CurrentRegion.Select.SpecialCells(xlCellTypeVisible).Copy.Sheets(3).Range("A1").PasteSpecial xlPasteColumnWidths.Sheets(3).Range("A1").PasteSpecial xlPasteAll
以上三段为基本相同的语句，将a列单元格作为筛选条件，命名给iname，选中sheet2中所有单元格，筛选，第6个，条件为a列条件，复制可视单元格，粘贴新的工作簿中的sheet1。以此类推
.SaveAs Filename:=ThisWorkbook.Path & "" & ifilename & ".xlsx".Close Savechanges:=TrueEnd WithNext nEnd Sub
粘贴格式至新的工作表，粘贴内容至新的工作表，存储新的工作簿至本表相同路径下，关闭工作簿
