工资表一键生成工资条

verywondful

有问题直接加QQ1205995591

探索者lin

好像代码这样写，生成工资条速度不快。加Application.Calculation = xlCalculationManual结束加Application.Calculation = xlCalculationAutomatic

verywondful

foru 发表于 2015-8-7 16:54
这么多个附件，都不知道你哪个是正确的

都可以用，只是多了些小功能。

foru

这么多个附件，都不知道你哪个是正确的

bpw0258

学习学习再学习,谢谢分享!

verywondful

verywondful 发表于 2015-7-3 13:27
已分享代码！

Sub 生成有空白行的工资条()
'
' 生成有空白行的工资条

    Sheets("工资表").Select ' 选择工资表并复制
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy ' 选择工资表并复制
   
    Sheets("工资条").Select '从A3选择性粘贴工资表
    Range("A3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False '从A3选择性粘贴工资表
    Range("A2").Select

Dim i As Integer

Dim endrow As Integer

  endrow = Sheet1.Range("a65536").End(xlUp).Row '探测到数据区最后一行

  For i = 5 To endrow '插入次数
  
    ActiveCell.Range("A1:AD2").Select     '复制带空白行工资条表头
    Application.CutCopyMode = False
    Selection.Copy                         '复制带空白行工资条表头
    ActiveWindow.LargeScroll ToRight:=-1
    ActiveCell.Offset(3, 0).Range("A1").Select
    Selection.Insert Shift:=xlDown          '隔行插入表头
   
  Next i '插入次数
     
     Dim rng As Range      '选择工资条数据区内所有空行
     For i = 1 To Range("a65536").End(xlUp).Row + 1
         If Cells(i, 1) = 0 And rng Is Nothing Then
             Set rng = Cells(i, 1)
         ElseIf Cells(i, 1) = 0 Then
             Set rng = Union(rng, Cells(i, 1))
         End If
     Next
     rng.EntireRow.Select    '选择工资条数据区内所有空行
     
     Selection.RowHeight = 5  '将工资条数据区内所有空行行高调整为5
     
     
End Sub

verywondful

verywondful 发表于 2015-6-30 12:53
Sub 生成有空白行的工资条()
'
' 生成有空白行的工资条

Sub 生成有空白行的工资条()
'
' 生成有空白行的工资条

    Sheets("工资表").Select ' 选择工资表并复制
    Range("A1").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy ' 选择工资表并复制
   
    Sheets("工资条").Select '从A3选择性粘贴工资表
    Range("A3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False '从A3选择性粘贴工资表
    Range("A2").Select

Dim i As Integer

Dim endrow As Integer

  endrow = Sheet1.Range("a65536").End(xlUp).Row '探测到数据区最后一行

  For i = 5 To endrow '插入次数
  
    ActiveCell.Range("A1:AD2").Select     '复制带空白行工资条表头
    Application.CutCopyMode = False
    Selection.Copy                         '复制带空白行工资条表头
    ActiveWindow.LargeScroll ToRight:=-1
    ActiveCell.Offset(3, 0).Range("A1").Select
    Selection.Insert Shift:=xlDown          '隔行插入表头
   
  Next i '插入次数
     
     Dim rng As Range      '选择工资条数据区内所有空行
     For i = 1 To Range("a65536").End(xlUp).Row + 1
         If Cells(i, 1) = 0 And rng Is Nothing Then
             Set rng = Cells(i, 1)
         ElseIf Cells(i, 1) = 0 Then
             Set rng = Union(rng, Cells(i, 1))
         End If
     Next
     rng.EntireRow.Select    '选择工资条数据区内所有空行
     
     Selection.RowHeight = 5  '将工资条数据区内所有空行行高调整为5
     
     
End Sub

verywondful

chguangze 发表于 2015-3-30 16:19
VBA密码呢！是否能共享一下

已分享代码！

verywondful

verywondful 发表于 2015-6-30 12:53
Sub 生成有空白行的工资条()
'
' 生成有空白行的工资条

分享第一版代码

verywondful

verywondful 发表于 2015-3-29 17:32
工资表一键生成工资条（最多生成30列）

Sub 生成有空白行的工资条()
'
' 生成有空白行的工资条

    Sheets("工资表").Select
    Range("A1:Z194").Select
    Selection.Copy
    Sheets("工资条").Select
    Range("A3").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A2").Select
Dim endrow As Integer
Dim i As Integer
  endrow = Sheet1.Range("a65536").End(xlUp).Row - 1

  For i = 4 To endrow
  
    ActiveCell.Range("A1:Z2").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.LargeScroll ToRight:=-1
    ActiveCell.Offset(3, 0).Range("A1").Select
    Selection.Insert Shift:=xlDown
   
  Next i

End Sub