그림을 10 개만 만들려고합니다. 줄을 아래로 돌리면 다음 줄로 되돌아갑니다. 누구든지 나를 도울 수 있습니까?

Question

이것은 제가 지금까지 가지고있는 것입니다. 나는 10 열 뒤의 그림을 어떻게 되돌려 놓을 지 알 수 없습니다.

Sub InsertPictures() 
    Dim PicList() As Variant 
    Dim PicFormat As String 
    Dim Rng As Range 
    Dim sShape As Shape 
    Dim MaxWidth# 
    On Error Resume Next 
    PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True) 
    xColIndex = Application.ActiveCell.Column 
    If IsArray(PicList) Then 
     xRowIndex = Application.ActiveCell.Row 
     For lLoop = LBound(PicList) To UBound(PicList) 
      Set Rng = Cells(xRowIndex, xColIndex) 
      With ActiveSheet.Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, -1, -1) 
       .LockAspectRatio = True 
       .Height = 100 * 3/4 
       Rng.RowHeight = .Height 
       If MaxWidth < .Width Then 
        MaxWidth = .Width 
       End If 
      End With 
      xRowIndex = xRowIndex + 1 
     Next 
     Rng.ColumnWidth = MaxWidth/Rng.Width * Rng.ColumnWidth 
     Rng.ColumnWidth = MaxWidth/Rng.Width * Rng.ColumnWidth 
     Rng.ColumnWidth = MaxWidth/Rng.Width * Rng.ColumnWidth 
     For Each sShape In ActiveSheet.Shapes 
      sShape.Left = MaxWidth/2 - sShape.Width/2 
     Next 
    End If 
End Sub 

Answer 1

변경 내용을 원래 행과 비교하여 xRowIndex으로 추적하면됩니다. 이> 10 가지 업데이트 행과 열

리팩토링은 (다른 몇 가지 개선)이되면

다음

Sub InsertPictures() 
    Dim PicList() As Variant 
    Dim PicFormat As String 
    Dim Rng As Range 
    Dim sShape As Shape 
    Dim MaxWidth# 
    Dim xColIndex As Long, xRowIndex As Long, lLoop As Long 
    Dim xColIncrement As Long, xRowInit As Long 
    Dim ws As Worksheet 

    Set ws = ActiveSheet ' <-- better to be explicit rather than rely on implicit ActiveSheet reference 
    'On Error Resume Next <-- dont just ignore all errors 
    PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True) 
    xColIncrement = 1 ' <-- adjust to how many columns to increment by 
    xColIndex = Application.ActiveCell.Column 
    xRowInit = Application.ActiveCell.Row 
    xRowIndex = xRowInit 
    With ws 
     If IsArray(PicList) Then 
      For lLoop = LBound(PicList) To UBound(PicList) 
       Set Rng = .Cells(xRowIndex, xColIndex) 
       With .Shapes.AddPicture(PicList(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, -1, -1) 
        .LockAspectRatio = True 
        .Height = 100 * 3/4 
        Rng.RowHeight = .Height 
        If MaxWidth < .Width Then 
         MaxWidth = .Width 
        End If 
       End With 
       xRowIndex = xRowIndex + 1 
       ' Check if rows is > 10 different to initial row 
       If xRowIndex >= xRowInit + 10 Then 
        Rng.ColumnWidth = MaxWidth/Rng.Width * Rng.ColumnWidth 
        MaxWidth = 0 
        xColIndex = xColIndex + xColIncrement 
        xRowIndex = xRowInit 
       End If 
      Next 
      Rng.ColumnWidth = MaxWidth/Rng.Width * Rng.ColumnWidth 
     End If 
    End With 
End Sub 

Answer 2

은 약간 단순화 된 버전입니다 :

Sub InsertPictures() ': DrawingObjects.Delete: Cells.Delete ' used for testing 
    Dim picList, pic, picFormat As String 
    Dim rng As Range, sShape As Shape, MaxWidth As Double 

    picList = Application.GetOpenFilename(picFormat, MultiSelect:=True) 
    If Not IsArray(picList) Then Exit Sub ' picList = False if no files selected 

    Set rng = ActiveCell 
    Application.ScreenUpdating = False ' optional to make it faster 

    For Each pic In picList 
     With Shapes.AddPicture(pic, 0, 1, rng.Left, rng.Top, -1, -1) 
      .LockAspectRatio = True 
      rng.RowHeight = rng.RowHeight * 10 
      .Height = rng.Height 
      If MaxWidth < .Width Then MaxWidth = .Width 
     End With 

     Set rng = rng(2) ' move to the cell below 
    Next 

    rng.ColumnWidth = MaxWidth * 255/1342.5 

    For Each sShape In Shapes 
     sShape.Left = rng.Left + (rng.Width - sShape.Width)/2 
    Next 
    Application.ScreenUpdating = True 
End Sub