如何在Excel中根据数据表中一列数据去拆分数据表，产生其他的多个表格。

王传奇wcq

求大神指导下，谢谢！

shenjr@163.com

请使用润乾集算器，关于excel的各种数据处理问题均可简单几行代码解决
先下载试用版，满意后再用个人租用版，一年才几十元，非常便宜
QQ联系：70777019，976695，13065247，184305475

zjdh

拆成啥样你总该发个样板啊！

王传奇wcq

zjdh 发表于 2018-9-21 21:54
拆成啥样你总该发个样板啊！

谢谢！您的回复。我的要求就是截图的那样，把第一个表的数据按照省份那列，拆分成不同的工作表放到当前工作簿第一个表的后面（或另外生成按省份命名的工作簿）

王传奇wcq

Sub parse_data()        
Dim lr As Long        
Dim ws As Worksheet        
Dim vcol, i As Integer        
Dim icol As Long        
Dim myarr As Variant        
Dim title As String        
Dim titlerow As Integer        
vcol =2               
Set ws = Sheets("明细")               
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row        
title = "A1:C1"                  
titlerow = ws.Range(title).Cells(1).Row        
icol = ws.Columns.Count        
ws.Cells(1, icol) = "Unique"        
For i = 2 To lr        
On Error Resume Next        
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then        
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)        
End If        
Next        
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))        
ws.Columns(icol).Clear        
For i = 2 To UBound(myarr)        
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""        
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then        
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""        
Else        
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)        
End If        
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")        
Sheets(myarr(i) & "").Columns.AutoFit        
Next        
ws.AutoFilterMode = False        
ws.Activate        
End Sub        
这个代码在Set ws = Sheets("明细")   时显示下标越界，要怎么解决？请大神帮忙看看。

zjdh

安装费.rar (135.15 KB, 下载次数: 15)

2018-9-23 17:47 上传

点击文件名下载附件

王传奇wcq

谢谢！zjdh老师的帮忙！

王传奇wcq

zjdh 发表于 2018-9-23 17:47

老师，我的是2010版Excel，把代码复制到另外表格中使用时，显示add作用于对象'sheets'时失败。这个要怎么解决？这个有没有通用的代码可以使用的？

zjdh

王传奇wcq 发表于 2018-9-24 11:07
老师，我的是2010版Excel，把代码复制到另外表格中使用时，显示add作用于对象'sheets'时失败。这个要怎么 ...

那直接运行我的附件是否有问题呢？

zjdh

把 Sheets.Add(after:=Sheets(Sheets.Count)).Name = NM(J)
分解成
Sheets.Add(after:=Sheets(Sheets.Count))
ActiveSheet.Name = NM(J)
试试