|
楼主 |
发表于 2023-10-6 19:03
|
显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
谢谢回复,各位的回复。
- Function MergeDate(Rs As Recordset, Sht As Worksheet)
- Dim Rng As Range
- With Sht
- Set Rng = .Cells(.Cells(65536, 2).End(xlUp).Row + 2, 1)
- Debug.Print Rng.Address
- Rng.CopyFromRecordset Rs
- Set Rng = Rng.Resize(Rs.RecordCount + 0, 1)
- Rng.Select
- Rng.Merge
- Set Rng = Rng.CurrentRegion
- Rng.Select
- ''
- With Selection.Borders(xlEdgeLeft)
- .LineStyle = xlContinuous
- .ColorIndex = xlAutomatic
- .TintAndShade = 0
- .Weight = xlMedium
- End With
- With Selection.Borders(xlEdgeTop)
- .LineStyle = xlContinuous
- .ColorIndex = xlAutomatic
- .TintAndShade = 0
- .Weight = xlMedium
- End With
- With Selection.Borders(xlEdgeBottom)
- .LineStyle = xlContinuous
- .ColorIndex = xlAutomatic
- .TintAndShade = 0
- .Weight = xlMedium
- End With
- With Selection.Borders(xlEdgeRight)
- .LineStyle = xlContinuous
- .ColorIndex = xlAutomatic
- .TintAndShade = 0
- .Weight = xlMedium
- End With
- With Selection.Borders(xlInsideVertical)
- .LineStyle = xlContinuous
- .ColorIndex = xlAutomatic
- .TintAndShade = 0
- .Weight = xlMedium
- End With
- With Selection.Borders(xlInsideHorizontal)
- .LineStyle = xlContinuous
- .ColorIndex = xlAutomatic
- .TintAndShade = 0
- .Weight = xlMedium
- End With
- '''
- End With
- End Function
- Private Sub dSqlCreateFolder()
- Application.DisplayAlerts = False
- Dim oFolder As Folder, oFile As File, oFile1 As File
- Dim Fso As Scripting.FileSystemObject
- Set Fso = New Scripting.FileSystemObject
- Dim Sht As Worksheet
- Set Sht = Sheet4
- Set Sht = Sheets("TraverseFolderFile")
- Sht.Activate
- Dim Rng As Range, oRng As Range
- Set Rng = Sht.Range("A1:Z" & Sht.Cells(65536, 1).End(xlUp).Row + 10)
- Debug.Print Rng.Address
- Dim Rs As Recordset, Rs1 As Recordset, Str
- Dim oPath, oPath1
- Dim oDate As Date
- ''
- With Sheet2
- .Activate
- .Cells.Clear
- .Cells.Font.Size = 9
- ''
- Str = "Select Distinct Format(日期,'yyyy-mm')" & _
- " From [" & Sht.Name & "$" & Rng.Address(0, 0) & "] "
- 'Debug.Print Str
- ''
- Set Rs = SqlRetuRs(Str)
- .Cells(2, 20).CopyFromRecordset Rs
-
- Rs.MoveFirst
-
- For ii = 0 To Rs.RecordCount - 1
- If IsDate(Rs.Fields(0)) Then
- oDate = Rs.Fields(0)
- Str = "Select Format(日期,'yyyy-mm'), Format(日期,'yyyy-mm-dd')" & _
- " From [TraverseFolderFile$A1:Z47627] Where 日期 >= #" & Format(oDate, "yyyy/mm/dd") & "# and 日期 < #" & Format(oDate + 1, "yyyy/mm/dd") & "#"
- Str = "Select Format(日期,'yyyy-mm'), Format(日期,'yyyy-mm-dd')" & _
- " From [TraverseFolderFile$A1:Z47627] Where 日期 >= #" & Format(oDate, "yyyy/mm") & "# and 日期 < #" & Format(oDate + 1, "yyyy/mm") & "#"
- Str = "Select distinct Format(日期,'yyyy年mm月'), Format(日期,'yyyy年mm月dd日')" & _
- " From [TraverseFolderFile$A1:Z47627] Where 日期 >= #" & Format(oDate, "yyyy/mm") & "# and 日期 < #" & Format(oDate + 32, "yyyy/mm") & "#"
- 'Str = "Select distinct Format(日期,'yyyy年mm月'), Format(日期,'yyyy年mm月dd日')" & _
- " From [TraverseFolderFile$A1:Z47627] Where int(日期)= #" & Format(oDate, "yyyy/mm") & "#"
- Set Rs1 = SqlRetuRs(Str)
- If Rs1.RecordCount > 0 Then
- MergeDate Rs1, Sheet2
- End If
-
- End If
- Rs.MoveNext
- Next ii
- End With
- Application.DisplayAlerts = True
- End Sub
复制代码 |
|