' Macro1 Macro ' ' 快捷键: Ctrl+p ' Dim zz_date As String * 8, zz_year As String * 4, zz_month As String * 2, zz_day As String * 2 Dim shopid As String * 4, fName As String, curPath As String, endRows As Integer '把当前日期按yyyymmdd格式赋值给zz_date变量 zz_year = Year(Now()) zz_month = Month(Now()) zz_day = Day(Now()) If Len(RTrim(zz_month)) = 1 Then zz_month = "0" & RTrim(zz_month) If Len(RTrim(zz_day)) = 1 Then zz_day = "0" & RTrim(zz_day) zz_date = zz_year & zz_month & zz_day '清空数据表 Sheets("sheet1").Select Cells.Clear Dim strConn As String, strSQL As String Dim conn As ADODB.Connection Dim ds As ADODB.Recordset Dim col As Integer curPath = ActiveWorkbook.Path '连接数据库的字符串 strConn = "Provider=SQLOLEDB.1;Persist Security Info=True;User ID=sa;Password=sql;Initial Catalog=hyreport;Data Source=10.2.0.1;Connect Timeout=720; " '查询语句 strSQL = "select * from Hy_KPI_Shop_Dept_WeekRpt order by 店铺代码,课类编码 " Set conn = New ADODB.Connection Set ds = New ADODB.Recordset '打开数据库连接 conn.Open strConn conn.CommandTimeout = 720 With ds '根据查询语句获得数据 .Open strSQL, conn '自动控制加入所有列标题 For col = 0 To ds.Fields.Count - 1 '请注意Offset(0, col)中的参数一定要正确 Worksheets("sheet1").Range("A1").Offset(0, col).Value = ds.Fields(col).Name Next '加入所有行数据 Worksheets("sheet1").Range("A1").Offset(1, 0).CopyFromRecordset ds End With '关闭数据库连接和清空资源 Set ds = Nothing conn.Close Set conn = Nothing '中间数据处理过程略 '然后执行自动筛选 Cells.Select Selection.AutoFilter '取shopid值并导入到各个文件中 Worksheets("shopid").Activate ActiveSheet.Range("A50").Select Do While (ActiveCell.Value <> "") shopid = ActiveCell.Value fName = shopid & "周报" & zz_date & ".xls" If Dir(curPath & "\" & shopid, vbDirectory) = vbNullString Then ChDir curPath MkDir curPath & "\" & shopid End If Workbooks.Add ActiveSheet.Cells.Select Selection.Interior.ColorIndex = 2 Application.DisplayAlerts = False ActiveWorkbook.SaveAs Filename:=curPath & "\" & shopid & "\" & fName, FileFormat:=xlExcel7 Workbooks("门店周报.xls").Worksheets("sheet1").Activate Selection.AutoFilter Field:=1, Criteria1:=shopid ActiveSheet.Rows("1:1").Select ActiveSheet.Range(Selection, Selection.End(xlDown)).Select Selection.Copy Windows(fName).Activate Sheets("Sheet1").Range("A1:A1").Select ActiveSheet.Paste Application.CutCopyMode = False ActiveWorkbook.Save ActiveWindow.Close Workbooks("门店周报.XLS").Worksheet s("shopid").Activate Cells(ActiveCell.Row + 1, 1).Select Loop '撤销自动筛选 Workbooks("门店周报.xls").Worksheets("sheet1").Activate Selection.AutoFilter '----------保存全部到总表---- Dim B00B As String Worksheets("shopid").Activate ActiveSheet.Range("A49").Select B00B = ActiveCell.Value fName = B00B & "周报总表" & zz_date & ".xls" If Dir(curPath & "\" & B00B, vbDirectory) = vbNullString Then ChDir curPath MkDir curPath & "\" & B00B End If Workbooks.Add ActiveSheet.Cells.Select Selection.Interior.ColorIndex = 2 Application.DisplayAlerts = False ActiveWorkbook.SaveAs Filename:=curPath & "\" & B00B & "\" & fName, FileFormat:=xlExcel12 Workbooks("门店周报.xls").Worksheets("sheet1").Activate ActiveSheet.Rows("1:1").Select ActiveSheet.Range(Selection, Selection.End(xlDown)).Select Selection.Copy Windows(fName).Activate Sheets("Sheet1").Range("A1:A1").Select ActiveSheet.Paste Application.CutCopyMode = False ActiveWorkbook.Save ActiveWindow.Close Workbooks("门店周报.xls").Worksheets("sheet1").Activate 'Windows("门店周报.xls").Activate ActiveWindow.Close End

VBA数据库查询及数据自动导出多Excel报表