关于shaperange的用法！

smiletwo

smiletwo

Sub 照片()
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    If ThisWorkbook.Sheets.Count >= 2 Then
        For m = Sheets.Count To 2 Step -1
            Sheets(m).Delete
        Next
    End If
    arr = Sheet8.Range("A1").CurrentRegion
    Do While UBound(arr) - (Sheets.Count - 1) * 4 > 2
        For m = 2 To UBound(arr) Step 4
            Set xsht = Sheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            xsht.Name = "拆分" & Sheets.Count - 1
            xsht.Rows("2:5").RowHeight = 320
            xsht.Columns("D").ColumnWidth = 22
            xsht.Columns("G").ColumnWidth = 30
            Sheet8.Range("A1:F1").Copy xsht.Range("A1:F1")
            ReDim brr(1 To 4, 1 To UBound(arr, 2))
            For i = 1 To 4
                brr(i, 1) = "=row()-1"
                For j = 2 To UBound(arr, 2)
                    brr(i, j) = arr(i + m - 1, j)
                Next j
            Next i
            xsht.Range("A2").Resize(UBound(brr), UBound(brr, 2)) = brr
            For i = 1 To UBound(brr)
                Set Rng = xsht.Range("G" & i + 1)
                picpath = ThisWorkbook.Path & "\5.10核酸图片\" & brr(i, 3) & ".jpg"
                If Dir(picpath) <> "" Then
                    xsht.Pictures.Insert(picpath).Select
                    xsht.AddShape
                    With Selection
                        .ShapeRange.LockAspectRatio = msoFalse
                        .Width = Rng.Width - 2
                        .Height = Rng.Height - 2
                        .Top = Rng.Top + 1
                        .Left = Rng.Left + 1
                    End With
                End If
            Next i
        Next m
    Loop
    applicaiton.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

幸福花开0304

smiletwo 发表于 2023-2-8 11:05
Sub 照片()
    On Error Resume Next
    Application.ScreenUpdating = False

谢谢老师，又学习了一个新知识。