Question

我遇到了一些问题。

我们需要制作一个小的单个单元格，将其更改为大约1000条客户声明（excel）。我使用openpyxl在python中进行了更改，所有公司徽标均消失了。

我已经编译了VBA来放回图像，但是由于第二页的顶部不是固定的行号，因此很难将它们放在第二页的正确位置。

但是，客户名称标记在第二页的顶部。

有没有一种方法可以搜索B列中的客户名称，并在同一行中插入公司徽标，但右边要保留9列。

这是我到目前为止所拥有的：

Sub Example()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String, Fnum As Long
Dim mybook As Workbook
Dim CalcMode As Long
Dim sh As Worksheet
Dim ErrorYes As Boolean

'Fill in the path\folder where the files are
MyPath = "Path\to\excels"

'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
    MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
    MsgBox "No files found"
    Exit Sub
End If

'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
    Fnum = Fnum + 1
    ReDim Preserve MyFiles(1 To Fnum)
    MyFiles(Fnum) = FilesInPath
    FilesInPath = Dir()
Loop

'Change ScreenUpdating, Calculation and EnableEvents
With Application
    CalcMode = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
End With

'Loop through all files in the array(myFiles)
If Fnum > 0 Then
    For Fnum = LBound(MyFiles) To UBound(MyFiles)
        Set mybook = Nothing
        On Error Resume Next
        Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
        On Error GoTo 0

        If Not mybook Is Nothing Then


            'Change cell value(s) in one worksheet in mybook
            On Error Resume Next
            With mybook.ActiveSheet.Pictures.Insert("C:Path\to\Pic.jpg")

                    With .ShapeRange
                        .LockAspectRatio = msoTrue
                        .Width = 40
                        .Height = 55
            End With
                        .Left = ActiveSheet.Range("K1").Left
                        .Top = ActiveSheet.Range("K1").Top
                        .Placement = 1
                        .PrintObject = True


            End With

            With ActiveSheet.Range("B12:L13").BorderAround(ColorIndex:=xlAutomatic, Weight:=xlMedium)

            End With

            If Err.Number > 0 Then
                ErrorYes = True
                Err.Clear
                'Close mybook without saving
                mybook.Close savechanges:=False
            Else
                'Save and close mybook
                mybook.Close savechanges:=True
            End If
            On Error GoTo 0
        Else
            'Not possible to open the workbook
            ErrorYes = True
        End If

    Next Fnum
End If

If ErrorYes = True Then
    MsgBox "There are problems in one or more files, possible problem:" _
         & vbNewLine & "protected workbook/sheet or a sheet/range that not exist"
End If

'Restore ScreenUpdating, Calculation and EnableEvents
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = CalcMode
End With

结束子

Answer 1

您可以使用：

Option Explicit

Sub image()

    Dim i As Long, Lastrow As Long
    Dim pic As Picture
    Dim rng As Range

    With ThisWorkbook.Worksheets("Sheet1")

        Lastrow = .Cells(.Rows.Count, "O").End(xlUp).Row

        For i = 1 To Lastrow

            If .Range("O" & i).Value = "Import" Then

                Set rng = .Range("O" & i).Offset(0, -9)

                With .Pictures.Insert("C:\Users\XXXXX\Desktop\download.jpg")
                    .Top = rng.Top
                    .Left = rng.Left
                End With

            End If

        Next i

    End With

End Sub

如何根据单元格值插入和偏移图像

1 个答案: