Question

我们在一个文件夹中有图片（Jpeg，Jpg，PNG），我需要将这些图片复制到excel工作表，如A2，B2，C2，D2单元格。

使用下面的代码，我可以复制为A2，A3，A4等，但如何在下面的代码而不是Row中更改colunm。我可以通过保持计数器不变来使行保持不变。

我使用过在线教程代码并稍作改动以符合我的要求。

Sub AddOlEObject()

    Dim mainWorkBook As Workbook

    Set mainWorkBook = ActiveWorkbook
    Sheets("SingleProfile").Activate
    Folderpath = "C:\Users\sandeep.hc\Pics"
    Set fso = CreateObject("Scripting.FileSystemObject")
    NoOfFiles = fso.GetFolder(Folderpath).Files.Count
    Set listfiles = fso.GetFolder(Folderpath).Files
    For Each fls In listfiles
       strCompFilePath = Folderpath & "\" & Trim(fls.Name)
        If strCompFilePath <> "" Then
            If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
                 counter = counter + 1
                  'Sheets("Object").Range("A" & counter).Value = fls.Name
                  'Sheets("Object").Range("B" & counter).ColumnWidth = 25
                'Sheets("Object").Range("B" & counter).RowHeight = 100
                Sheets("SingleProfile").Range("A" & counter).Activate
                Call insert(strCompFilePath, counter)
                Sheets("SingleProfile").Activate
            End If
        End If
    Next
mainWorkBook.Save
End Sub

Function insert(PicPath, counter)
'MsgBox PicPath
    With ActiveSheet.Pictures.insert(PicPath)
        With .ShapeRange
            .LockAspectRatio = msoFalse
            '.Width = 50
            '.Height = 70
        End With
        .Left = ActiveSheet.Range("A" & counter).Left
        .Top = ActiveSheet.Range("A" & counter).Top
        .Placement = 1
        .PrintObject = True
    End With
End Function

需要帮助优化以下代码

根据用户的输入，我能够得到我想要的解决方案。

我想现在优化代码，因为我在编码方面非常新手可以帮助优化或帮助改进编码技术以改进下面

Sub AddOlEObject()

    Dim mainWorkBook As Workbook

    Set mainWorkBook = ActiveWorkbook
    Sheets("SingleProfile").Activate
    Folderpath = "C:\Users\sandeep.hc\Pics"
    Set fso = CreateObject("Scripting.FileSystemObject")
    NoOfFiles = fso.GetFolder(Folderpath).Files.Count
    Set listfiles = fso.GetFolder(Folderpath).Files
    For Each fls In listfiles
       strCompFilePath = Folderpath & "\" & Trim(fls.Name)
        If strCompFilePath <> "" Then
            If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
                 counter = 29
                 counter1 = counter1 + 1

                Call insert(strCompFilePath, counter, counter1)
                'Sheets("SingleProfile").Activate
                counter1 = counter1 + 17
            End If
        End If
    Next
mainWorkBook.Save
End Sub

Function insert(PicPath, counter, counter1)
'MsgBox PicPath
    With ActiveSheet.Pictures.insert(PicPath)
        With .ShapeRange
            .LockAspectRatio = msoFalse
            .Width = 875
            .Height = 300
        End With
        .Left = ActiveSheet.Cells(counter, counter1).Left
        .Top = ActiveSheet.Cells(counter, counter1).Top
        .Placement = 1
        .PrintObject = True
    End With
End Function

Answer 1

而不是ActiveSheet.Range("C2")使用ActiveSheet.Cells(2,3)等等。

顺便说一句，将工作表作为另一个函数参数传递而不是激活它会更安全。这样你每次调用函数时都不需要记住激活它。我还建议您在模块开头使用Option Explicit，特别是如果您是VBA的新手。

Answer 2

换乘第1行

   .Left = ActiveSheet.Cells(counter, 1).Left
   .Top = ActiveSheet.Cells(counter,1).Top

从文件夹复制图像并通过VBA将其粘贴到Excel

2 个答案: