求修改生成工资条代码，谢谢！

凌空一羽

dssrmyh 发表于 2018-8-9 21:15
请再帮忙优化一下，生成工资条是只想保留最上面那个超链接图标，谢谢！

Sub lkyy()
ar = Range("a1").CurrentRegion
Dim shp As Shape
For Each shp In Sheet20.Shapes
   If shp.ID <> 4 Then shp.Delete
Next
ym = Replace(Split(ar(1, 1), "月")(0), "年", ".")
myl = UBound(ar, 2) - 2
ReDim br(1 To UBound(ar) * 4, 1 To myl)
myr = Range("b2").End(xlDown).Row
For i = 3 To myr
    n = ar(i, 1)
    For j = 2 To myl
        br(n * 4 - 3, j - 1) = ar(2, j)
        br(n * 4 - 2, j - 1) = ar(i, j)
    Next
    br(n * 4 - 3, myl) = "月份"
    br(n * 4 - 2, myl) = ym
Next
Sheets("工资条").Activate
Cells.ClearContents
Range("a5:r20000").Borders.LineStyle = xlNone
For i = 2 To n
    Rows("1:4").Copy Cells(i * 4 - 3, 1)
    Sheet20.Shapes("图片1").Select
    Selection.Copy
    Cells(i * 4 - 3, "n").Select
    ActiveSheet.Paste
Next
Range("a1").Resize(n * 4, UBound(br, 2)) = br
End Sub

dssrmyh

凌空一羽 发表于 2018-8-9 22:25
Sub lkyy()
ar = Range("a1").CurrentRegion
Dim shp As Shape

谢谢，但还是没有达到我想要的效果。生成工资条后还是复制了N个图片。我最终的目的是只有一个图片

凌空一羽

dssrmyh 发表于 2018-8-9 22:45
谢谢，但还是没有达到我想要的效果。生成工资条后还是复制了N个图片。我最终的目的是只有一个图片

Sub 生成工资条()
'
'
'
'
'
Application.ScreenUpdating = False
    Set shwk = ActiveSheet
    If InStr(shwk.Name, "工资表") < 1 Then GoTo qut
    y = InStr(Cells(1, 1).Text, "月")
    If y < 2 Then GoTo qut
    ym = "'" & Replace(Left(Cells(1, 1).Text, y - 1), "年", ".")
    For qsh = 2 To 8
        If Cells(qsh, 1).Value = "序号" Then Exit For
    Next qsh
    qsh = qsh + 1
    Sheets("工资条").Select
    Rows("2:600").Delete

    kuan = ActiveSheet.UsedRange.Columns.Count

    If Range("a1").Value <> "姓名" Or Cells(1, kuan) <> "月份" Then GoTo qut
    i = qsh
    j = 1

    Do While i < 300

       If shwk.Cells(i, 2).Text < " " Then Exit Do
       Sheets("工资条").Select
       If i > qsh Then
          Rows("1:1").Select
          Selection.Copy
          j = (i - qsh) * 3 + 1

          rg = j & " : " & j
          Cells(j, 1).Activate
          ActiveSheet.Paste
       End If
       shwk.Select
       xm = shwk.Cells(i, 2).Text
       shwk.Range(Cells(i, 2), Cells(i, kuan - 1)).Select
       Selection.Copy

       Sheets("工资条").Select
       Cells(j + 1, 1).Select
       Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
       Cells(j + 1, kuan).Value = ym

       'Stop
       Range("B4").Activate
       Cells.Find(What:=xm, After:=ActiveCell, LookIn:=xlFormulas, lookat:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) _
        .Activate
        r = ActiveCell.Row
        c = ActiveCell.Column
       ' zrjt = Cells(r, c + 1).Value
       ' shbt = Cells(r, c + 2).Value
       qita = Cells(r, c + 1).Value
       Sheets("工资条").Select
       'Cells(j + 1, kuan + 1).Value = zrjt
       'Cells(j + 1, kuan + 2).Value = shbt
       Cells(j + 1, kuan - 1).Value = qita
       'Cells(j + 1, kuan - 1).Value = qita + Cells(j + 1, kuan - 3).Value
      ' Stop
       i = i + 1
       If shwk.Cells(i, 4).Value < 0 Or shwk.Cells(i, 4).Value > 10000 Then Exit Do
    Loop
    Sheets("工资条").Select
    ActiveSheet.UsedRange.Select
    Selection.ShrinkToFit = True
    Selection.HorizontalAlignment = xlGeneral
    Selection.HorizontalAlignment = xlCenter
    Application.GoTo Reference:="R1C1"
    Range("A3").Select
    MsgBox "已生成新的工资条,共" & i - qsh & "人。"
qut:
Application.ScreenUpdating = True

End Sub

Sub lkyy()
ar = Range("a1").CurrentRegion
Dim shp As Shape
For Each shp In Sheet20.Shapes
   If shp.ID <> 4 Then shp.Delete
Next
ym = Replace(Split(ar(1, 1), "月")(0), "年", ".")
myl = UBound(ar, 2) - 2
ReDim br(1 To UBound(ar) * 4, 1 To myl)
myr = Range("b2").End(xlDown).Row
For i = 3 To myr
    n = ar(i, 1)
    For j = 2 To myl
        br(n * 4 - 3, j - 1) = ar(2, j)
        br(n * 4 - 2, j - 1) = ar(i, j)
    Next
    br(n * 4 - 3, myl) = "月份"
    br(n * 4 - 2, myl) = ym
Next
Sheets("工资条").Activate
Cells.ClearContents
Range("a5:r20000").Borders.LineStyle = xlNone
For i = 2 To n
    Rows("1:4").Copy Cells(i * 4 - 3, 1)
Next
For Each shp In Sheet20.Shapes
   If shp.ID <> 4 Then shp.Delete
Next
Range("a1").Resize(n * 4, UBound(br, 2)) = br
End Sub