根据单元格内容插入空白单元格

徐庆征 · 发表于 2020-6-29 11:44

具体样式在表里面麻烦各位大佬帮我看看

any1009 · 发表于 2020-6-29 12:20

试试看：

Sub test()
n = 1
For i = 1 To [A65536].End(3).Row
If Range("A" & i).Value = Range("A" & i + 1).Value Then
n = n + 1
Else
For j = 1 To 5 - n
Rows(i + j).Insert
Next
i = i + 5 - n
n = 1
End If
Next
End Sub

复制代码

liulang0808 · 发表于 2020-6-29 12:31

Sub 按钮1_Click()
Dim brr()
arr = [a1].CurrentRegion
ReDim brr(1 To UBound(arr) * 5, 1 To 3)
r = 1
For j = 1 To 3
      brr(r, j) = arr(1, j)
Next j
For j = 2 To UBound(arr)
      If arr(j, 1) <> arr(j - 1, 1) Then
         r = r + 6 - (r Mod 5)
      Else
         r = r + 1
      End If
      For i = 1 To 3
         brr(r, i) = arr(j, i)
      Next i
Next j
Sheets(3).[a1].Resize(r, 3) = brr
End Sub

liulang0808 · 发表于 2020-6-29 12:32

附件内容供参考。。。。。。

rhloo · 发表于 2020-6-29 12:37

在模块中加入以下代码

Sub 加空行()
With ThisWorkbook.Worksheets("原数据")
Dim strX As String, i As Integer, h As Integer, s As Integer
h = 1
s = 1
strX = .Cells(h, 1).Value & ""
Do While strX <> ""
If .Cells(h + 1, 1).Value & "" = strX Then
h = h + 1
s = s + 1
Else
strX = .Cells(h + 1, 1).Value & ""
For i = 1 To 5 - s Step 1
h = h + 1
.Rows(h).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next i
s = 0
End If
Loop
End With
End Sub

复制代码

sj15627581616 · 发表于 2020-6-29 12:46

Sub ts()
Dim d As Object, arr, brr
Set d = CreateObject("scripting.dictionary")
arr = Sheets("原数据").Range("a1:c" & Sheets("原数据").Cells(Rows.Count, 1).End(3).Row)
For i = 1 To UBound(arr)
d(arr(i, 1)) = ""
Next
brr = d.keys
For i = 1 To d.Count * 5
Cells(i, 1) = brr(Int((i - 1) / 5))
Next
js = 1
For i = 1 To Cells(Rows.Count, 1).End(3).Row
For r = js To UBound(arr)
If arr(r, 1) = Cells(i, 1) Then
Cells(i, 2) = arr(r, 2)
Cells(i, 3) = arr(r, 3)
js = r + 1
Exit For
End If
Next
Next
For i = 1 To Cells(Rows.Count, 1).End(3).Row
If Cells(i, 2) = "" And Cells(i, 3) = "" Then
Cells(i, 1).ClearContents
End If
Next
End Sub

复制代码

rhloo · 发表于 2020-6-29 12:49

Sub 加空行()
With ThisWorkbook.Worksheets("原数据")
Dim strX As String, i As Integer, h As Integer, s As Integer
h = 1
s = 1
strX = .Cells(h, 1).Value & ""
Do While strX <> ""
If .Cells(h + 1, 1).Value & "" = strX Then
h = h + 1
s = s + 1
Else
strX = .Cells(h + 1, 1).Value & ""
For i = 1 To 5 - s Step 1
h = h + 1
.Rows(h).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next i
s = 0
End If
Loop
End With
End Sub

复制代码

笨鸟飞不高 · 发表于 2020-6-29 14:32

Sub AwTest()
Dim i%, j%, r%, k%, iRow%, arr
With Sheets("原数据")
      iRow = .Cells(.Rows.Count, 1).End(3).Row
      arr = .Range("A1:C" & iRow)
      ReDim brr(1 To UBound(arr) * 5, 1 To 3)
      r = 1: k = 1
      For j = 1 To UBound(arr, 2)
         brr(1, j) = arr(1, j)
      Next
      For i = 2 To UBound(arr)
         If arr(i, 1) <> arr(i - 1, 1) Then
            k = k + 1: r = 5 * k - 4
            For j = 1 To UBound(arr, 2)
                  brr(r, j) = arr(i, j)
            Next
         Else
            r = r + 1
            For j = 1 To UBound(arr, 2)
                  brr(r, j) = arr(i, j)
            Next
         End If
      Next
End With
With Sheets("想要的样式")
      .Cells.Clear
      .[a1].Resize(r, 3) = brr
End With
End Sub

这个不是发过一贴了吗??

芐雨 · 发表于 2020-6-29 14:36

Sub t()
Dim arr, brr
Dim i&, j&, n&, x&
arr = Range("A1:A" & Cells(Rows.Count, 1).End(3).Row + 1)
ReDim brr(0 To UBound(arr) * 5, 1 To 1)
For i = 1 To UBound(arr) - 1
If arr(i, 1) = arr(i + 1, 1) Then
n = n + 1
brr(x + n, 1) = arr(i, 1)
Else
brr(x, 1) = arr(i, 1)
n = 0
x = x + 5
End If
Next
Range("F1").Resize(UBound(brr)) = brr
End Sub

复制代码

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

[求助] 根据单元格内容插入空白单元格

最新热点 /1