如何在EXCEL中用VBA批量插入图片大小一样并到指定位置摆放 10
类似的程序我做过。将代码放在这里，你自己学习吧。
Sub 删除表格()
'
'
Dim mys
Application.DisplayAlerts = False
For Each mys In Worksheets
If mys.Name <> "TOOLS" And mys.Name <> "模板" Then
mys.Delete
End If
Next
Application.DisplayAlerts = True
End Sub
Sub 创建表格()
Dim stMedd As String
Dim dir1 As String
dir1 = ThisWorkbook.Path
Dim bmpfile, ar(), n%, i%, j%, k%, ll%
Dim br(1 To 100)
bmpfile = Dir(dir1 & "\*.bmp")
Do Until Len(bmpfile) = 0
n = n + 1
ReDim Preserve ar(1 To n)
ar(n) = bmpfile
bmpfile = Dir
Loop
ll = 0
For i = 1 To n
If InStr(ar(i), "..bmp") > 0 Then
ll = ll + 1
br(ll) = Mid(ar(i), 1, Len(ar(i)) - 5)
End If
Next i
j = Int(n / 2 / 4)
If n / 2 Mod 4 > 0 Then
j = j + 1 'j记录要生成多少张新表格
End If
Dim FileName1, FileName2 As String
For k = 1 To j
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("模板").Select
Cells.Select
Selection.Copy
Sheets(Sheets.Count).Select
ActiveSheet.Paste
ActiveSheet.Name = Str(k)
For l = 1 To 4
If (k - 1) * 4 + l <= n / 2 Then
' FileName1 = ar((k - 1) * 4 + (l - 1) * 2 + 1)
' FileName2 = ar((k - 1) * 4 + (l - 1) * 2 + 2)
FileName1 = br((k - 1) * 4 + l) + "..bmp"
FileName2 = br((k - 1) * 4 + l) + ".bmp"
Set objTargetcell = Cells(2 + (l - 1) * 3, 2)
ActiveSheet.Pictures.Insert(dir1 & "\" & FileName2).Select
With Selection
.Top = objTargetcell.Top
.Left = objTargetcell.Left
End With
Set objTargetcell = Cells(2 + (l - 1) * 3, 4)
ActiveSheet.Pictures.Insert(dir1 & "\" & FileName1).Select
With Selection
.Top = objTargetcell.Top
.Left = objTargetcell.Left
End With
'添加联通信息
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\联通.PNG").Select
With Selection
.Top = objTargetcell.Top + 148
.Left = objTargetcell.Left - 88
End With
End If
Next
Next
End Sub
Sub 联通置顶()
Dim i As Integer
For i = 1 To ThisWorkbook.Sheets.Count
Sheets(i).Select
For Each myshape In ActiveSheet.Shapes
If InStr(myshape.AlternativeText, "联通") > 0 Then
myshape.ZOrder msoBringToFront
End If
Next
Next
End Sub
Sub 打印格式()
Dim i As Integer
For i = 3 To ThisWorkbook.Sheets.Count
Sheets(i).Select
Range("B2:E10").Select
ActiveSheet.PageSetup.PrintArea = "$B$2:$E$14"
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.708661417322835)
.RightMargin = Application.InchesToPoints(0.708661417322835)
.TopMargin = Application.InchesToPoints(0.748031496062992)
.BottomMargin = Application.InchesToPoints(0.748031496062992)
.HeaderMargin = Application.InchesToPoints(0.31496062992126)
.FooterMargin = Application.InchesToPoints(0.31496062992126)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 180
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
Next
End Sub
Sub s()
删除表格
创建表格
联通置顶
打印格式
End Sub
这个程序用于联通的营业网点。月末将客户的身份证照片提取到excel表格然后打印。
全部过程只要按一个键就可以了。
