A列每个单元格复制N遍，每几个单元格插入N个空白格

gitigou

求大神VBA，A列每个单元格复制N遍，每几个单元格插入N个空白格 每格复制N遍，每种插入N格空白格.zip (11.69 KB, 下载次数: 12)

2023-4-30 13:52 上传

点击文件名下载附件

GG函数

你可以使用我开发的REPT2函数或使用我的EXCEL插件，免费

scyss

=IF(MOD(ROW(A1)-1,F$1*F$2+F$3)+1>F$1*F$2,"",INDEX(A:A,INT((ROW(A1)-1-F$3*(INT(ROW(A1)/(F$1*F$2+F$3))))/F$1)+1,1)&"")

E风卍行H

1. Sub 复制()
   
2.     Dim nRept As Long   '复制次数
   
3.     Dim nSpace As Long  '间隔数（几种花）
   
4.     Dim nBlank As Long  '空白数
   
5.     Dim arr, n As Long, m As Long
   
6.     Dim trr(1 To 1, 1 To 1)
   
7.     Dim brr(), b As Long
   
8.     Dim i As Long, j As Long, k As Long
   
9.    
   
10.     nRept = Val(ActiveSheet.Shapes("TextBox 4").TextFrame2.TextRange.Text)
    
11.     nSpace = Val(ActiveSheet.Shapes("TextBox 5").TextFrame2.TextRange.Text)
    
12.     If nSpace = 0 Then nSpace = 1
    
13.     nBlank = Val(ActiveSheet.Shapes("TextBox 3").TextFrame2.TextRange.Text)
    
14.    
    
15.     Rem 判断复制次数是否为0
    
16.     If nRept = 0 Then
    
17.         MsgBox "请填写复制次数！"
    
18.         Exit Sub
    
19.     End If
    
20.    
    
21.     Rem 数据存数组
    
22.     n = Range("A" & Rows.Count).End(xlUp).Row
    
23.     If n = 1 Then
    
24.         trr(1, 1) = Range("A1").Value
    
25.         arr = trr
    
26.     Else
    
27.         arr = Range("A1").Resize(n, 1).Value
    
28.     End If
    
29.    
    
30.     Rem 计算
    
31.     ReDim brr(1 To n * nRept + ((n \ nSpace) + 1) * nBlank)
    
32.     For i = 1 To n
    
33.         For j = i To IIf(i + nSpace - 1 > n, n, i + nSpace - 1)
    
34.             Rem 重复
    
35.             For k = 1 To nRept
    
36.                 b = b + 1
    
37.                 brr(b) = arr(j, 1)
    
38.             Next
    
39.         Next
    
40.         
    
41.         Rem 空白
    
42.         b = b + 4
    
43.         
    
44.         i = i + nSpace - 1
    
45.     Next
    
46.    
    
47.     Columns("B").ClearContents  '清除原内容
    
48.    
    
49.     Rem 输入结果
    
50.     Range("B1").Resize(UBound(brr), 1) = Application.WorksheetFunction.Transpose(brr)
    
51.    
    
52.     MsgBox "处理完成！"
    
53. End Sub

复制代码

清风竹-

请看附件。

gitigou

清风竹- 发表于 2023-4-30 15:34
请看附件。

空格填4以上运行，会提示下标越界，是怎么回事呢

gitigou

E风卍行H 发表于 2023-4-30 15:02

谢谢！😊

不知道为什么

scyss 发表于 2023-4-30 14:28
=IF(MOD(ROW(A1)-1,F$1*F$2+F$3)+1>F$1*F$2,"",INDEX(A:A,INT((ROW(A1)-1-F$3*(INT(ROW(A1)/(F$1*F$2+F$3)) ...

供参考  附件。。。。。

niko88819

清风竹- 发表于 2023-4-30 15:34
请看附件。

清风竹-老师可以贴出分享代码吗?下载打开代码都遗失

清风竹-

gitigou 发表于 2023-4-30 22:08
空格填4以上运行，会提示下标越界，是怎么回事呢

重新下载一下，已更新。