excel根据条件列转行_Excel vba-根据不同筛选条件筛选后，拆分成新的excel工作簿...

以下代码为工作中的真实案例（不是真实数据~~~），本人是销售方，每季度都要和关联方进行对账，这工作量大的可怕估计有五六十家关联方，我又不能把所有数据都发送给关联方，最好是根据每个关联方的名字来进行筛选，然后将交易、往来、现金流三个表格的数据发送给对方。这样每家就只能看到每家的数据，我也不用重复做工作，筛选然后复制，要新建60个工作表，每家要粘贴三遍，那就是180遍~~我感觉我几天就没有了~~~

为了增加我工作效率，我研究了一晚上，写了以下代码。

新建一个excel，在sheet1里A列列明要查找的单位名称，C列则用来对新建的excel命名，用于区分是服务还是生产类公司。sheet2里复制粘贴“交易”数据，sheet3复制粘贴“往来”数据，sheet4“复制粘贴现金流”数据。在sheet1里新建了一个commandbutton。输入以下代码。

代码

Private Sub CommandButton1_Click()
Dim iPath$, ifilename$, iName$, ibook As Workbook
Dim i, n
Dim 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 '新生成的工作簿里面的sheet
Application.SheetsInNewWorkbook = 3 '定义新工作簿里有3个sheet
Set ibook = Workbooks.Add '新增一个worksheet
With ibook
For i = 1 To 3
With .Sheets(i)
     .name = shname(i - 1)
End With
Next i   '将三个工作sheet命名到新workbook中

将交易往来现金流赋值给shname

定义新的工作簿里有三张工作表

新增一个工作表

定义i从1到3

此过程为实现新建个工作簿按照c列命名，并建立三张工作表，分别命名为交易、往来、现金流

ThisWorkbook.Activate
iName = ThisWorkbook.Sheets(1).Cells(n, 1)
ActiveWorkbook.Sheets(2).Select
With Selection
             .AutoFilter
             .AutoFilter field:=6, Criteria1:=iName
             .CurrentRegion.Select
             .SpecialCells(xlCellTypeVisible).Copy
End With
.Sheets(1).Range("A1").PasteSpecial xlPasteColumnWidths
.Sheets(1).Range("A1").PasteSpecial xlPasteAll


ThisWorkbook.Activate
iName = ThisWorkbook.Sheets(1).Cells(n, 1)
ActiveWorkbook.Sheets(3).Select
With Selection
             .AutoFilter
             .AutoFilter field:=6, Criteria1:=iName
             .CurrentRegion.Select
             .SpecialCells(xlCellTypeVisible).Copy
End With
.Sheets(2).Range("A1").PasteSpecial xlPasteColumnWidths
.Sheets(2).Range("A1").PasteSpecial xlPasteAll


ThisWorkbook.Activate
iName = ThisWorkbook.Sheets(1).Cells(n, 1)
ActiveWorkbook.Sheets(4).Select
With 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:=True
End With
Next n
End Sub

粘贴格式至新的工作表，粘贴内容至新的工作表，存储新的工作簿至本表相同路径下，关闭工作簿