从文件夹复制图像，并通过VBA将其粘贴到Excel
我们有一个文件夹中的图片（Jpeg，Jpg，PNG），我需要将这些图片复制到excel工作表，如A2，B2，C2，D2单元格。
使用下面的代码，我可以复制为A2，A3，A4等，但如何更改在下面的代码，而不是行的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 需要帮助来优化下面的代码
根据用户的input，我能够得到我想要的解决scheme。
我现在想优化代码，因为我在编码方面非常新手，可以帮助优化或帮助良好的编码技术改进
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
而不是ActiveSheet.Range("C2")使用ActiveSheet.Cells(2,3)等。
顺便说一下，将表单作为另一个函数参数而不是激活它会更安全。 这样你就不需要记住每次调用函数时都要激活它。 我还build议在模块开始时使用Option Explicit ，特别是如果您是VBA的新手。
在第1行中移动
.Left = ActiveSheet.Cells(counter, 1).Left .Top = ActiveSheet.Cells(counter,1).Top