|
- Set SHX = Worksheets("data")
- For Each SH In Worksheets
- If SH.Name <> SHX.Name Then
- SH.Delete
- End If
- Next
- Str_coon = "HDR=yes';Data Source =" & ThisWorkbook.FullName '//OFFICE2003,2007 通用
-
-
- Rem 先获取要拆分字段的不重复值
- StrSQL = "SELECT DISTINCT [品类]"
- StrSQL = StrSQL & " FROM [" & SHX.Name & "$]"
- StrSQL = StrSQL & " WHERE NOT [品类] IS NULL AND LEN([品类])>0"
- ARX = GET_SQL_To_Arr(StrSQL, Str_coon, False) '//不重复姓名放入二维数组
-
- If ARX(0, 0) <> "" And ARX(0, 0) <> "Error" Then
- ICINT = UBound(ARX) + 1
-
- For X = 0 To ICINT - 1 '//循环每一个值
- Rem 提示信息,在状态栏显示
- Application.StatusBar = "需拆分总数:" & ICINT & " 个,当前是第:" & X + 1 & " 个,当前品类是:" & ARX(X, 0)
- DoEvents
-
- Rem 查询对应数据
- StrSQL = ""
- StrSQL = StrSQL & "SELECT DISTINCT [日期]"
- StrSQL = StrSQL & " FROM [" & SHX.Name & "$A1:IT]"
- StrSQL = StrSQL & " WHERE [品类]='" & ARX(X, 0) & "'"
- StrSQL = StrSQL & " ORDER BY [日期]"
- BRX = GET_SQL_To_Arr(StrSQL, Str_coon, False)
-
- If BRX(0, 0) <> "" And BRX(0, 0) <> "Error" Then '//没有数据,在不保存
- Set SHW = Worksheets.Add
- SHW.Name = "" & ARX(X, 0)
- StrSQL = "SELECT [甜品]"
- For I = 0 To UBound(BRX, 1)
- StrSQL = StrSQL & ",SUM(IIF([日期]=#" & BRX(I, 0) & "#,[金额],0)) AS [" & Format(BRX(I, 0), "yyyy-MM-dd") & "]"
- Next
- StrSQL = StrSQL & " FROM [" & SHX.Name & "$]"
- StrSQL = StrSQL & " WHERE [品类]='" & ARX(X, 0) & "'"
- StrSQL = StrSQL & " GROUP BY [甜品]"
- SQLARR = GET_SQL_To_Arr(StrSQL, Str_coon, True)
- SHW.Range("A1").Value = ARX(X, 0)
- SHW.Range("A2").Resize(UBound(SQLARR, 1) + 1, UBound(SQLARR, 2) + 1) = SQLARR
- End If
- Next
- Else
- MsgBox "未发现拆分依据 需要的值!", vbInformation, "北极狐提示!!"
- End If
复制代码 |
|