|
Option Explicit
Sub test4()
Dim ar(), br, i&, j&, r&, k&, pic As Picture
Dim shp As Shape, Rng As Range, iPosRow&, iPosCol&, t#
Application.ScreenUpdating = False
Application.DisplayAlerts = False
t = Timer
With Sheets(1).[A1].CurrentRegion
For j = 1 To .Columns.Count Step 4
r = r + 1
ReDim Preserve ar(1 To r)
ar(r) = .Cells(1, j).Resize(.Rows.Count, 4)
Next j
End With
Cells.Clear
For Each shp In ActiveSheet.Shapes
If shp.type = msoPicture Then shp.Delete
Next
br = [{"A1",1;"A3",2;"B2",3;"A4",4}]
Set Rng = Sheets("模板").[A2:C5]
For i = 2 To UBound(ar(1))
iPosRow = (i - 2) * 4 + 1
For j = 1 To UBound(ar)
iPosCol = (j - 1) * 3 + 1
rngCopyToSame Rng, Cells(iPosRow, iPosCol)
With Cells(iPosRow, iPosCol)
For k = 1 To UBound(br)
.Range(br(k, 1)).Value = ar(j)(i, br(k, 2))
Next k
Call QRMain(.Value)
Call CreateBitmapQRCode(RGB(0, 0, 0), RGB(255, 255, 255))
Call QRCodeToClipboard
With .Range("A2")
.Select
ActiveSheet.Paste
Set pic = Selection
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.Height = .Height
Selection.Left = .Left + (.Width - Selection.Width) / 2
End With
Application.CutCopyMode = False
End With
Next j
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "执行完毕!_用时: " & Format(Timer - t, "0.00") & " 秒", 64
End Sub
Function rngCopyToSame(ByVal rngSel As Range, ByVal rngTarget As Range)
Dim i&
rngSel.Copy
rngTarget.PasteSpecial xlPasteColumnWidths
rngSel.Copy rngTarget
With rngTarget.Resize(rngSel.Rows.Count, rngSel.Columns.Count)
For i = 1 To .Rows.Count
.Rows(i).RowHeight = rngSel.Rows(i).RowHeight
Next i
End With
End Function |
评分
-
1
查看全部评分
-
|