求助一个VBA代码(提取指定文件夹内的图片和文字,列表组合并生成新文件)

liuwenjietz

将 faces文件夹与PersonInfo信息匹配填到安全教育上岗证模板上，数量根据PersonInfo自动计算，达到效果.jpg的效果 可以直接A4打印。 加wx酬谢

3190496160

先做个记号，再看看呗

3190496160

Sub 生成证件()
Application.ScreenUpdating = False
Set Sh = ThisWorkbook.Worksheets("上岗证")
f = Dir(ThisWorkbook.Path & "\PersonInfo.csv")
If f = "" Then MsgBox "数据源文件不存在": Exit Sub
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f, 0)
With wb.Worksheets("PersonInfo")
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a14:m" & rs)
End With
wb.Close False
ws = Sh.Cells(Rows.Count, 2).End(xlUp).Row + 10
  For Each a In Sh.Shapes
    a.Delete
Next
Sh.Rows("9:" & ws).Delete
Sh.Range("d2:d8,i2:i8") = Empty
m = 9
If (UBound(ar) - 1) / 2 = Int((UBound(ar) - 1) / 2) Then
    k = Int((UBound(ar) - 1) / 2)
Else
    k = Int((UBound(ar) - 1) / 2) + 1
End If
For i = 2 To k
    Sh.Rows("1:8").Copy Sh.Cells(m, 1)
    m = m + 8
Next i
ws = Sh.Cells(Rows.Count, 2).End(xlUp).Row
m = 2
For i = 2 To UBound(ar) Step 2
    Sh.Cells(m, 4) = ar(i, 1)
    Sh.Cells(m + 1, 4) = ar(i, 9)
    Sh.Cells(m + 2, 3) = ar(i, 10)
    Sh.Cells(m + 3, 3) = ar(i, 12)
    Sh.Cells(m + 4, 4) = ar(i, 13)
    Sh.Cells(m + 5, 4) = ar(i, 5)
    Sh.Cells(m + 6, 4) = ar(i, 11)
    fs1 = ThisWorkbook.Path & "\faces\" & Trim(ar(i, 1)) & "_" & Mid(ar(i, 5), 2, Len(ar(i, 5)) - 1) & ".jpg"
    If Dir(fs1) <> "" Then
        Sh.Select
           Sh.Range("e" & m & ":e" & m + 6).Select
           ActiveSheet.Pictures.Insert(fs1).Select
       With Selection.ShapeRange
         Selection.ShapeRange.LockAspectRatio = msoFalse
            .Top = Sh.Range("e" & m & ":e" & m + 6).Top + 1
            .Left = Sh.Range("e" & m & ":e" & m + 6).Left + 1
            .Width = Sh.Range("e" & m & ":e" & m + 6).Width
            .Height = Sh.Range("e" & m & ":e" & m + 6).Height
        End With
    End If
   
    If i = UBound(ar) Then GoTo 10
    Sh.Cells(m, 9) = ar(i + 1, 1)
    Sh.Cells(m + 1, 9) = ar(i + 1, 9)
    Sh.Cells(m + 2, 8) = ar(i + 1, 10)
    Sh.Cells(m + 3, 8) = ar(i + 1, 12)
    Sh.Cells(m + 4, 9) = ar(i + 1, 13)
    Sh.Cells(m + 5, 9) = ar(i + 1, 5)
    Sh.Cells(m + 6, 9) = ar(i + 1, 11)
    fs1 = ThisWorkbook.Path & "\faces\" & Trim(ar(i + 1, 1)) & "_" & Mid(ar(i + 1, 5), 2, Len(ar(i + 1, 5)) - 1) & ".jpg"
    If Dir(fs1) <> "" Then
        Sh.Select
           Sh.Range("j" & m & ":j" & m + 6).Select
           ActiveSheet.Pictures.Insert(fs1).Select
       With Selection.ShapeRange
         Selection.ShapeRange.LockAspectRatio = msoFalse
            .Top = Sh.Range("j" & m & ":j" & m + 6).Top + 1
            .Left = Sh.Range("j" & m & ":j" & m + 6).Left + 1
            .Width = Sh.Range("j" & m & ":j" & m + 6).Width
            .Height = Sh.Range("j" & m & ":j" & m + 6).Height
        End With
    End If
    m = m + 8
10:
Next i
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

打印.zip (550.89 KB, 下载次数: 44)

2020-1-23 13:28 上传

点击文件名下载附件

凌空一羽

Sub lkyy()
Dim i%, n%, r模板 As Range, c复制%, r%, L As Byte, Pic As Shape, t$
Dim Mp$, Mf, ar文(1 To 1000)
Mp = ThisWorkbook.Path & "\faces\"
Mf = Dir(Mp & "*.jpg")
Do While Mf <> ""
    m = m + 1
    ar文(m) = Mf
Mf = Dir()
Loop

With Workbooks.Open(ThisWorkbook.Path & "\PersonInfo.csv")
    ar = .Sheets("PersonInfo").Range("a15:M100")
    .Close 0
End With
ReDim br(1 To UBound(ar), 1 To 7)
For i = 1 To UBound(ar)
    If ar(i, 1) <> "" Then
        n = n + 1
        br(n, 1) = ar(i, 1)
        br(n, 2) = ar(i, 9)
        br(n, 3) = ar(i, 10)
        br(n, 4) = ar(i, 12)
        br(n, 5) = ar(i, 13)
        br(n, 6) = ar(i, 5)
        br(n, 7) = ar(i, 11)
    End If
Next
Rows("2:2000").Delete
For Each Pic In ActiveSheet.Shapes
    If Pic.Left < Range("k1").Left Then Pic.Delete
Next
c复制 = Int(n / 2 + 0.5)
Set r模板 = Sheet2.Rows("1:8")
For i = 1 To c复制
    r模板.Copy Cells(i * 8 - 7, 1)
Next
For i = 1 To n
    r = Int((i + 1) / 2) * 8 - 6
    L = 3 + ((i + 1) Mod 2) * 5
    For j = 0 To 6
        Cells(r + j, L) = br(i, 1 + j)
    Next
    t = ""
    For j = 1 To m
        If InStr(ar文(j), br(i, 1)) Then t = Mp & ar文(j): Exit For
    Next
    If t <> "" Then '判断是否存在这个相片
        Set p = Sheet1.Pictures.Insert(t)
        With p
            .ShapeRange.LockAspectRatio = msoFalse
            .Top = Cells(r, L + 2).Top
            .Left = Cells(r, L + 2).Left
            .Height = 106.5
            .Width = 81.75
        End With
    End If
Next
End Sub

凌空一羽

请看看附件……