[已解决]工资条增加空行

czl103 · 发表于 2017-6-26 18:00

本帖最后由 czl103 于 2017-6-27 16:27 编辑

详见附件，表中VBA代码无法增加空行，烦请大虾帮忙增加一段代码，实现第二个工作表的效果。最好有详细代码解释，不胜感激额！

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2017-6-27 09:39

格式自己刷吧，我只做数据。

Sub aaa()
Dim arr, brr, i&, j&, r&
arr = [a1].CurrentRegion
ReDim brr(1 To UBound(arr) * 3, 1 To UBound(arr, 2))
For i = 2 To UBound(arr)
r = r + 1
For j = 1 To UBound(arr, 2)
brr(r, j) = arr(1, j)
brr(r + 1, j) = arr(i, j)
Next j
r = r + 2
Next i
Sheets(2).[a1].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

复制代码

跳转到最佳答案楼层

WYH141 · 发表于 2017-6-27 08:29

有大神帮他解决下吗

大灰狼1976 · 发表于 2017-6-27 09:10

Sub aaa()
Dim i&, s$
For i = 3 To [a65536].End(3).Row
s = s & "," & i & ":" & i
Next i
Range(Mid(s, 2)).Insert
End Sub

复制代码

czl103 · 发表于 2017-6-27 09:25

大灰狼1976 发表于 2017-6-27 09:10

谢谢大虾试了下这个只是增加空行，没有增加标题，可否将这两个条件加起来达到第二个工作表的效果？不胜感激！

大灰狼1976 · 发表于 2017-6-27 09:39

这个最佳答案由大灰狼1976 给出，感谢大灰狼1976 的回答。

单击隐藏图章

格式自己刷吧，我只做数据。

Sub aaa()
Dim arr, brr, i&, j&, r&
arr = [a1].CurrentRegion
ReDim brr(1 To UBound(arr) * 3, 1 To UBound(arr, 2))
For i = 2 To UBound(arr)
r = r + 1
For j = 1 To UBound(arr, 2)
brr(r, j) = arr(1, j)
brr(r + 1, j) = arr(i, j)
Next j
r = r + 2
Next i
Sheets(2).[a1].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

复制代码

chart888 · 发表于 2017-6-27 09:40

本帖最后由 chart888 于 2017-6-27 09:52 编辑

Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Dim i&, Mxrow&
Sheets("工资条").[a1].CurrentRegion.Copy Sheets("Date").[a1] '备份数据
With Sheets("Date")
.Range("A1:G" & Rows.Count).ClearContents '清空数据
Mxrow = .Cells(.Rows.Count, 1).End(3).Row '判断最下行
For i = Mxrow To 3 Step -1 '插入空行
.Rows(i & ":" & i).Insert Shift:=xlDown
Next
.Rows("1:1").Copy '复制表头
.Range("a2:a" & .Cells(.Rows.Count, 1).End(3).Row). _
SpecialCells(xlCellTypeBlanks).Select '定位空行
.Paste '粘贴表头
Mxrow = .Cells(.Rows.Count, 1).End(3).Row - 1
For i = Mxrow To 3 Step -2 '插入空行
.Rows(i & ":" & i).Insert Shift:=xlDown
Next
.[a1].Select
End With
Application.ScreenUpdating = True
End Sub

复制代码

idnoidno · 发表于 2017-6-27 11:43

Sub aaa()
Dim arr, brr, i&, j&, r&
arr = [a1].CurrentRegion
ReDim brr(1 To UBound(arr) * 3, 1 To UBound(arr, 2)) '要空行，一條工資單3行，Array 擴充3倍
r = 1
For i = 2 To UBound(arr)
For j = 1 To UBound(arr, 2)
brr(r, j) = arr(1, j) '每個工資單是一樣抬頭項目
brr(r + 1, j) = arr(i, j) '每個人的工資項目
Next j
r = r + 3 'r=1跳到r=4(剛好空了一行)
Next i
Sheets(2).[a1].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

复制代码

剽竊一下大灰狼兄的代碼(因為他用的好艱深耶)，自己稍微修改一下，自己比較懂

idnoidno · 发表于 2017-6-27 11:44

Sub aaa()
Dim arr, brr, i&, j&, r&
arr = [a1].CurrentRegion
ReDim brr(1 To UBound(arr) * 3, 1 To UBound(arr, 2)) '要空行，一條工資單3行，Array 擴充3倍
r = 1
For i = 2 To UBound(arr)
For j = 1 To UBound(arr, 2)
brr(r, j) = arr(1, j) '每個工資單是一樣抬頭項目
brr(r + 1, j) = arr(i, j) '每個人的工資項目
Next j
r = r + 3 'r=1跳到r=4(剛好空了一行)
Next i
Sheets(2).[a1].Resize(UBound(brr), UBound(brr, 2)) = brr
End Sub

复制代码

剽竊一下大灰狼兄的代碼(因為他用的好艱深耶)，自己稍微修改一下，自己比較懂

苏子龙 · 发表于 2017-6-27 12:14

本帖最后由苏子龙于 2017-6-28 08:53 编辑

chart888 发表于 2017-6-27 09:40

Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Dim i&, Mxrow&

With Sheets("Date")
.Range("A1:G" & Rows.Count).ClearContents '清空数据
Sheets("工资条").[a1].CurrentRegion.Copy Sheets("Date").[a1] '备份数据，放到这里
Mxrow = .Cells(.Rows.Count, 1).End(3).Row '判断最下行
For i = Mxrow To 3 Step -1 '插入空行
.Rows(i & ":" & i).Insert Shift:=xlDown
Next
.Rows("1:1").Copy '复制表头
.Range("a2:a" & .Cells(.Rows.Count, 1).End(3).Row). _
SpecialCells(xlCellTypeBlanks).Select '定位空行
.Paste '粘贴表头
Mxrow = .Cells(.Rows.Count, 1).End(3).Row - 1
For i = Mxrow To 3 Step -2 '插入空行
.Rows(i & ":" & i).Insert Shift:=xlDown
Next
.[a1].Select
End With
Application.ScreenUpdating = True
End Sub

测试中文字体，

大灰狼1976 · 发表于 2017-6-27 12:38

苏子龙发表于 2017-6-27 12:14
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Dim i&, Mxrow&

老兄，我看你的代码中间也经常会出现乱码，是不是系统也不是简体中文版的呀。

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

[已解决]工资条 增加空行

评分

[已解决]工资条增加空行