时间戳

首页 > 解决方案 > 如何从另一个工作表复制图片并粘贴到单元格注释中

excel - 如何从另一个工作表复制图片并粘贴到单元格注释中

问题描述

所以我在网上寻找答案，但没有找到答案，我想要我的代码做的是从文件夹中打开一个工作表，从该工作表中获取照片，最后粘贴到我当前工作簿中单元格内的评论中。这是我的代码

Dim folder As String

Private Sub Workbook_Open()

    folder = ThisWorkbook.path

End Sub

Sub populatePDA()

    'Application.ScreenUpdating = False

    Dim wb As Workbook
    Dim ws As Variant
    Dim path As String
    Dim fileName As String
    Dim p As Picture
    Dim img As Variant
    Dim cb As Comment

    Set ws = ThisWorkbook.Sheets("PDA")
    path = folder & "\PDA\"
    fileCount = 0
    fileName = Dir(path & "*.xlsm")

    Do While fileName <> ""

        Set wb = Workbooks.Open(path & fileName) 'Open Workbook
        ws.Range("A3:F3").Insert (xlShiftDown)
        ws.Range("A3") = wb.Sheets(1).Range("B16").Value 'Item Name
        ws.Range("B3") = wb.Sheets(1).Range("B17").Value 'S/N
        ws.Range("C3") = wb.Sheets(1).Range("G7").Value 'Description
        ws.Range("D3") = wb.Sheets(1).Range("H12").Value 'Calibration
        ws.Range("E3") = wb.Sheets(1).Range("H13").Value 'Expiration

        For Each p In wb.Sheets(1).Pictures

            p.CopyPicture
            Set img = ws.Paste
            Set cb = ws.Range("F3").AddComment
            cb.Text Text:=""
            cb.Shape.Fill.UserPicture (img)

        Next p

        wb.Close
        fileName = Dir

    Loop

    'Application.ScreenUpdating = True
End Sub

标签： excelvba

解决方案

你什么都不说，我完成了一些事情......

我对您的代码进行了一些修改，使其在工作表中添加新的插入，用于新的打开文件，并根据您的需要处理它们（我理解）。请测试下一个代码：

Sub populatePDA()
 Dim fileName As String, path As String
 Dim ws As Worksheet, wb As Workbook, p As Shape, fileCount As Long
 Dim cb As Comment, i As Long, arrCol As Variant, k As Long
  arrCol = Split("A,B,C,D,E", ",")
  Set ws = ThisWorkbook.Sheets("PDA")
  path = ThisWorkbook.path & "\PDA\"
  fileCount = 0
  fileName = Dir(path & "*.xlsm")

 k = 2
 Application.ScreenUpdating = False
 Do While fileName <> ""
    Set wb = Workbooks.Open(path & fileName) 'Open Workbook
    k = k + 1
        ws.Range("A" & k & ":E" & k).Insert (xlShiftDown)
        ws.Range("A" & k) = wb.Sheets(1).Range("B16").Value 'Item Name
        ws.Range("B" & k) = wb.Sheets(1).Range("B17").Value 'S/N
        ws.Range("C" & k) = wb.Sheets(1).Range("G7").Value 'Description
        ws.Range("D" & k) = wb.Sheets(1).Range("H12").Value 'Calibration
        ws.Range("E" & k) = wb.Sheets(1).Range("H13").Value 'Expiration
    i = 2
    For Each p In wb.Sheets(1).Shapes
       If p.Type = msoPicture Then
          i = i + 1
          ws.Activate
          If Not ws.Range(arrCol(i - 3) & k).Comment Is Nothing Then _
                                  ws.Range(arrCol(i - 3) & k).Comment.Delete
          Set cb = ws.Range(arrCol(i - 3) & k).AddComment
           cb.text text:=""
           With cb.Shape
              .width = p.width: .height = p.height
           End With
          cb.Shape.Fill.UserPicture (SelImPathCh(p, wb))
       End If
    Next p
    ws.Activate
    wb.Close False

    fileName = Dir
 Loop
 ws.UsedRange.EntireColumn.AutoFit
 Application.ScreenUpdating = False
End Sub

能够进行图片插入的函数是下一个（由上面的main代码调用）：

Private Function SelImPathCh(img As Shape, Optional wb As Workbook) As String
  Dim ch As ChartObject, sh As Worksheet, sFile As String
  If Not wb Is Nothing Then Set sh = wb.Sheets(1)
  sFile = ThisWorkbook.path & "\Pict1.jpg"
  Set ch = sh.ChartObjects.Add(left:=1, _
       top:=1, width:=img.width, _
                         height:=img.height)
   If Not wb Is Nothing Then wb.Activate: sh.Activate
   img.Copy: ch.Activate: ActiveChart.Paste
   ch.Chart.Export sFile
   ch.Delete
   SelImPathCh = sFile
End Function

该wb变量Optional仅用于我的测试需要。我使用了一张现有的工作簿，并在调用该函数时跳过了它...

推荐阅读