大神帮忙写个代码，不同时间加个空行，内容下移

q490525427 · 发表于 2024-8-24 16:15

大神帮忙写个代码，不同时间加个空行，内容下移

感谢！

小凡、、、 · 发表于 2024-8-24 16:26

一个循环的事

ykcbf1100 · 发表于 2024-8-24 16:34

参与一下，结果在表2

q490525427 · 发表于 2024-8-24 16:35

小凡、、、发表于 2024-8-24 16:26
一个循环的事

谢谢老师

ykcbf1100 · 发表于 2024-8-24 16:35

参与一下。。。

Sub ykcbf() '//2024.8.24
Set d = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
r = .Cells(Rows.Count, 2).End(3).Row
arr = .[b1].Resize(r, 1)
End With
ReDim brr(1 To 10000, 1 To 1)
For i = 2 To UBound(arr)
s = arr(i, 1)
If Not d.exists(s) Then
d(s) = Array(i, i)
Else
t = d(s)
t(1) = i
d(s) = t
End If
Next
For Each k In d.keys
r1 = d(k)(0): r2 = d(k)(1)
For i = r1 To r2
m = m + 1
brr(m, 1) = arr(i, 1)
Next
m = m + 1
Next
With Sheets("Sheet2")
.Columns(2) = ""
.[b2].Resize(m, 1) = brr
End With
MsgBox "OK！"
End Sub

复制代码

q490525427 · 发表于 2024-8-24 16:36

ykcbf1100 发表于 2024-8-24 16:34
参与一下，结果在表2

谢谢老师，

清风竹- · 发表于 2024-8-24 16:42

请看附件。

gwjkkkkk · 发表于 2024-8-24 19:26

Option Explicit
Sub test1()
Dim ar, br, i&, j&, p&, n&, r&

With [B2].CurrentRegion
      p = 1
      ar = .Resize(.Rows.Count + 1)
      ReDim br(1 To UBound(ar) * 3, 0)
      For i = 2 To UBound(ar) - 1
         If ar(i + 1, 1) <> ar(p, 1) Then
            For j = p To i
                  r = r + 1
                  br(r, 0) = ar(j, 1)
            Next j
            r = r + 1
            p = i + 1
         End If
      Next i
End With

With [D2].Resize(r - 1)
      .NumberFormatLocal = "yyyy/m/d h:mm"
      .Value = br
End With
End Sub

gwjkkkkk · 发表于 2024-8-24 19:31

。。。。。。。。。。

q490525427 · 发表于 2024-8-24 20:37

清风竹- 发表于 2024-8-24 16:42
请看附件。

谢谢老师

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

[求助] 大神帮忙写个代码，不同时间加个空行，内容下移

评分

评分

评分

评分

评分