获取不重复日期组合

6739912

哪位大神帮我解决，先谢了

蓝桥玄霜

日期的代码 ：

yaozong

Sub test()
  Dim d, arr, i&, s$
  Set d = CreateObject("Scripting.Dictionary")
  arr = Range("G2", [G65536].End(3)).Value
  For i = 1 To UBound(arr)
    s = CStr(Format(arr(i, 1), "yyyymm"))
    d(s) = Val(s)
  Next
  [a4] = Join(d.keys, ",")
  [a5] = Application.Small(d.items, 1) & "-" & Application.Small(d.items, d.Count)
End Sub

xiangbaoan

Option Explicit
Private Sub CommandButton1_Click()
Dim Cn As Object, S1$, S2$, ar, i%, s$
Set Cn = CreateObject("ADODB.Connection")
Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
S1 = "SELECT DISTINCT FORMAT(日期,'YYYYMM') FROM [Sheet1$G1:G" & [G65536].End(xlUp).Row & "]"
S2 = "SELECT FORMAT(MIN(日期),'YYYYMM'),FORMAT(MAX(日期),'YYYYMM') FROM [Sheet1$G1:G" & [G65536].End(xlUp).Row & "]"
ar = Cn.Execute(S1).GetRows
For i = 0 To UBound(ar, 2)
    s = s & "," & ar(0, i)
Next
With [a1]
    .Resize(2).NumberFormatLocal = "@"
    .Value = Mid(s, 2)
    With .Offset(1)
        .CopyFromRecordset Cn.Execute(S2)
        .Value = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(.Resize(, 2))), "-")
        .Offset(, 1) = ""
    End With
End With
Cn.Close
Set Cn = Nothing
End Sub

6739912

ar = Cn.Execute(S1).GetRows  
.CopyFromRecordset Cn.Execute(S2)         这段是什么意思

xiangbaoan

6739912 发表于 2019-8-24 11:50
ar = Cn.Execute(S1).GetRows  
.CopyFromRecordset Cn.Execute(S2)         这段是什么意思

Option Explicit
Private Sub CommandButton1_Click() '搞复杂了，这样就行，意思不好解释
Dim Cn As Object, Sq$, ar, i%, s$
Set Cn = CreateObject("ADODB.Connection")
Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
Sq = "SELECT DISTINCT FORMAT(日期,'YYYYMM') FROM [Sheet1$G1:G" & [G65536].End(xlUp).Row & "]"
ar = Cn.Execute(Sq).GetRows
For i = 0 To UBound(ar, 2)
    s = s & "," & ar(0, i)
Next
With [a1]
    .Resize(2).NumberFormatLocal = "@"
    .Value = Mid(s, 2)
    .Offset(1) = ar(0, 0) & "-" & ar(0, i - 1)
End With
Cn.Close
Set Cn = Nothing
End Sub

liangmutou01

Sub cs()
  Set conn = CreateObject("ADODB.Connection")
  Set jlj = CreateObject("ADODB.Recordset")
  conn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;HDR=yes';data source=" & ThisWorkbook.FullName
  conn.CursorLocation = adUseClient
  jlj.Open "select DISTINCT format(日期,'yyyy') from [Sheet1$g1:g65536];", conn, 1, 3
  Set nian = jlj.Clone(3)
  jlj.Close
  jlj.Open "select DISTINCT format(日期,'mm') from [Sheet1$g1:g65536];", conn, 1, 3
  jlj.ActiveConnection = Nothing
  Do
    Do
      jg = jg & nian.Fields(0).Value & "年" & jlj.Fields(0).Value & "月，"
      jlj.MoveNext
    Loop Until jlj.EOF
    nian.MoveNext
    jlj.MoveFirst
  Loop Until nian.EOF
  nian.MoveFirst
  Application.ScreenUpdating = False
  With Sheet1
    jlj.Sort = 日期
    nian.Sort = 日期
    .[a6] = "最小值："
    .[b6] = nian.Fields(0).Value & "年" & jlj.Fields(0).Value & "月"
    jlj.MoveLast
    nian.MoveLast
    .[a7] = "最大值："
    .[b7] = nian.Fields(0).Value & "年" & jlj.Fields(0).Value & "月"
    .[a5] = Left(jg, Len(jg) - 1)
    .[a5].WrapText = True
    .Rows("5:5").EntireRow.AutoFit
  End With
  nian.Close: jlj.Close
  conn.Close
  Application.ScreenUpdating = True
End Sub

6739912

蓝桥玄霜 发表于 2019-8-24 11:29
日期的代码 ：

数据源不排序，但结果排序更好