[已解决]提取数据并另存为新的文件VBA

chensir · 发表于 2014-5-13 08:57

本帖最后由 chensir 于 2014-5-13 11:00 编辑

求助vba语句：比如我要提取管理城市为北京的所有数据另存为一个新的文件，文件名的规则是此文件名后面加"-北京"，即"14年4月利润-北京"。这管理城市用输入框的形式，输入"北京"后，即另存为一个管理城市为北京的所有数据,并且透视表也要保留，即基础表和透视表都要保留。多谢各位帮忙。

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2014-5-13 10:54

chensir 发表于 2014-5-13 10:49
我知道了，另外如何把透视表一同带到新的表格里，可以做到吗我在文件里又加了一个透视表，谢谢

可以把数透表复制过去。

跳转到最佳答案楼层

hwc2ycy · 发表于 2014-5-13 09:11

直接通过SQL查询生成新文件吧。

chensir · 发表于 2014-5-13 09:19

hwc2ycy 发表于 2014-5-13 09:11
直接通过SQL查询生成新文件吧。

之所以要分表是因为不同的管理城市只能看自己的，一个文件按照管理城市的数量分成几个文件发给相关人员

hwc2ycy · 发表于 2014-5-13 09:32

Sub demo()
Dim AdoConn As Object
Dim AdoRst As Object
Dim AdoRst1 As Object
Const adUseClient = 3
Const adModeRead = 1
Dim i As Integer
Dim strSql$, strConn$
Dim strCity$
On Error GoTo ErrorHandler
strCity = InputBox("请输入要查询的城市：", , "北京")
If Len(strCity) = 0 Then MsgBox "查询输入不对": Exit Sub
strSql = "select * from [sheet1$a1:f] where 管理城市='" & strCity & "'"
Set AdoConn = CreateObject("ADODB.Connection")
strConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
"Data Source='" & ThisWorkbook.FullName & "';Extended Properties='Excel 8.0';"
With AdoConn
.CursorLocation = adUseClient
.Mode = adModeRead
.ConnectionString = strConn
.Open
End With
Set AdoRst = AdoConn.Execute(strSql)
With AdoRst
If .RecordCount > 0 Then
Workbooks.Add
For i = 0 To AdoRst.Fields.Count - 1
Cells(1, i + 1).Value = .Fields(i).Name
Next
Range("a2").CopyFromRecordset AdoRst
Dim ldot&
ldot = InStrRev(ThisWorkbook.Name, ".")
strConn = ThisWorkbook.Path & "" & Replace(ThisWorkbook.Name, Mid(ThisWorkbook.Name, ldot), "-" & strCity & Mid(ThisWorkbook.Name, ldot))
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=strConn, FileFormat:=xlOpenXMLWorkbookMacroEnabled
MsgBox "数据导出完成" & vbCr & strConn
Else
MsgBox "无数据可提取"
End If
End With
Set AdoRst = Nothing
AdoConn.Close
Set AdoConn = Nothing
Application.DisplayAlerts = True
Exit Sub
ErrorHandler:
Dim strErr$
strErr = strErr & "错误代码：" & Err.Number & vbCr
strErr = strErr & "错误描述：" & Err.Description & vbCr
strErr = strErr & "错误来源：" & Err.Source
MsgBox strErr, vbCritical + vbOKOnly
End Sub

复制代码

hwc2ycy · 发表于 2014-5-13 09:38

Sub demo()
Dim AdoConn As Object
Dim AdoRst As Object
Const adUseClient = 3
Const adModeRead = 1
Dim strSql$, strConn$, strCity$
Dim ldot&, i&
On Error GoTo ErrorHandler
'查询城市
strCity = InputBox("请输入要查询的城市：", , "北京")
If Len(strCity) = 0 Then MsgBox "查询输入不对": Exit Sub
'SQL语句和ADO连接字符串
strSql = "select * from [sheet1$a1:f] where 管理城市='" & strCity & "'"
strConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
"Data Source='" & ThisWorkbook.FullName & "';Extended Properties='Excel 8.0';"
'创建ADO连接对象
Set AdoConn = CreateObject("ADODB.Connection")
With AdoConn
.CursorLocation = adUseClient
.Mode = adModeRead
.ConnectionString = strConn
.Open
End With
'返回查询记录
Set AdoRst = AdoConn.Execute(strSql)
With AdoRst
If .RecordCount > 0 Then
Workbooks.Add
'标题行
For i = 0 To AdoRst.Fields.Count - 1
Cells(1, i + 1).Value = .Fields(i).Name
Next
'数据
Range("a2").CopyFromRecordset AdoRst
'原文件名中.号位置
ldot = InStrRev(ThisWorkbook.Name, ".")
'替换生成新文件名
strConn = ThisWorkbook.Path & "" & Replace(ThisWorkbook.Name, Mid(ThisWorkbook.Name, ldot), "-" & strCity & Mid(ThisWorkbook.Name, ldot))
Application.DisplayAlerts = False
'保存
ActiveWorkbook.SaveAs Filename:=strConn, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.DisplayAlerts = True
MsgBox "数据导出完成" & vbCr & strConn
Else
MsgBox "无数据可提取"
End If
End With
Set AdoRst = Nothing
AdoConn.Close
Set AdoConn = Nothing
Exit Sub
ErrorHandler:
Dim strErr$
strErr = strErr & "错误代码：" & Err.Number & vbCr
strErr = strErr & "错误描述：" & Err.Description & vbCr
strErr = strErr & "错误来源：" & Err.Source
MsgBox strErr, vbCritical + vbOKOnly
End Sub

复制代码

810126769 · 发表于 2014-5-13 09:45

Sub test()
Dim arr, brr(1 To 100000, 1 To 9), i&, j&, k&, st$
arr = Range("a1").CurrentRegion
st = InputBox("请输入要统计的管理城市", "输入")
k = 1
For i = 1 To UBound(arr)
If i = 1 Then
For j = 1 To UBound(arr, 2)
brr(i, j) = arr(i, j)
Next j
ElseIf arr(i, 3) = st Then
k = k + 1
For j = 1 To UBound(arr, 2)
brr(k, j) = arr(i, j)
Next j
End If
Next i
If brr(2, 1) <> "" Then
With Workbooks.Add
.Sheets(1).[a1].Resize(k, UBound(arr, 2)) = brr
.SaveAs ThisWorkbook.Path & "" & ThisWorkbook.Name & "-" & st & ".xlsx"
.Close True
End With
End If
End Sub

复制代码

qh8600 · 发表于 2014-5-13 09:48

14年4月利润.rar (21.43 KB, 下载次数: 10)

chensir · 发表于 2014-5-13 10:25

810126769 发表于 2014-5-13 09:45

多谢，请问透视表如何也保留在新的表内

chensir · 发表于 2014-5-13 10:25

qh8600 发表于 2014-5-13 09:48

多谢，请问透视表如何也保留在新的表内

chensir · 发表于 2014-5-13 10:27

本帖最后由 chensir 于 2014-5-13 10:50 编辑

hwc2ycy 发表于 2014-5-13 09:38

知道原因了

		自动登录	找回密码
密码			注册

[已解决]提取数据并另存为新的文件VBA

评分

评分