不让工资条生成出空白条

我就这样

因我工资表习惯采用固定格式，每一页都有空白行或者签字栏合计栏，采用了某前人的vba生成工资条，结果出现工资条空白，或者把签字栏合计栏也进行工资条打印，想完美生成只有产生工资人员才有的工资条，望大神帮我修改一下！

1. Sub 生成工资条()
   
2.     Dim arr, r%, i%, k%
   
3.     Application.ScreenUpdating = False
   
4.     r = Range("a65536").End(3).Row              '未清除数据前的下标
   
5.     If r > 7 Then Range("a8:r" & r).Delete      '删除原数据
   
6.     aa = Range("c2")
   
7.     'Set ws = Worksheets(aa)                    '把出库汇总表的表名用变量ws0替代
   
8.     With Sheets(aa)                             '读取工资表名
   
9.         r = .Range("a65536").End(3).Row         '工资表下标
   
10.         arr = .Range("a6:r" & r)                '工资表信息装入数组arr
    
11.     End With
    
12.     With Sheets("工资条")                       '对于工资条表
    
13.         For i = 1 To UBound(arr)                '数组循环
    
14.             k = (i - 1) * 3 + 5                 '计算数组行序与工资条每条增4行的序列关系
    
15.             If i > 1 Then                       '如果是第2个员工后面的所有员工则需先复制模板至下方
    
16.                Rows("5:7").Copy Rows(k)         '如果不是第1个员工先把表头模板的4行复制到下方
    
17.             End If
    
18.             .Cells(k + 1, 1).Resize(1, UBound(arr, 2)) = Application.Index(arr, i, 0)      '再把arr循环中的该员工信息粘贴到工资条对应的位置
    
19.         Next
    
20.     End With
    
21.     Application.ScreenUpdating = True
    
22. End Sub

复制代码

我就这样

自己顶自己，在线等大神！

vvw123

顶上去，我也想学习一下。

chxw68

修改好了。

stonelee2018

i = Range("a65536").End(xlUp).Row
    Range("b6:b" & i).SpecialCells(xlCellTypeBlanks).EntireRow.Select
    Selection.Offset(-1, 0).Delete
     Range("b6:b" & i).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

stonelee2018

把上边的代码放在生成工资条代码的后边

wj2368

我就这样 发表于 2019-4-22 09:48
自己顶自己，在线等大神！

。。。。。。。。。。。。。。

lsc900707

1. Sub 生成工资条()
   
2.     Dim arr, r&, i&, k&
   
3.     Application.ScreenUpdating = False
   
4.     r = Range("a65536").End(3).Row
   
5.     If r > 7 Then Range("a8:r" & r).Delete
   
6.     aa = Range("c2")
   
7.     With Sheets(aa)
   
8.         r = .Range("a65536").End(3).Row
   
9.         arr = .Range("a6:r" & r)
   
10.      End With
    
11.      ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
12.      For i = 1 To UBound(arr)
    
13.         If InStr(1, "岗位,部门", arr(i, 3)) = 0 Then
    
14.             m = m + 1
    
15.             For j = 1 To UBound(arr, 2)
    
16.                 brr(m, j) = arr(i, j)
    
17.             Next
    
18.         End If
    
19.     Next
    
20.     For i = 1 To UBound(brr)
    
21.         If Len(brr(i, 3)) Then
    
22.             k = (i - 1) * 3 + 5
    
23.         Else
    
24.             Exit For
    
25.         End If
    
26.         If i > 1 Then Cells(5, 1).Resize(3, 18).Copy Rows(k)
    
27.         Cells(k + 1, 1).Resize(1, UBound(brr, 2)) = Application.Index(brr, i, 0)
    
28.     Next
    
29.     Application.ScreenUpdating = True
    
30.     MsgBox "OK!", 64
    
31. End Sub

复制代码

lsc900707

测试参考附件：