将多个位图图像插入多个工作表

Question

在我的文件夹中，有AA.bmp，AA.txt，BB.bmp和BB.txt

我可以在单独的工作表中提取AA.txt和BB.txt的数据。

我是否也可以在与AA.txt相同的工作表中插入AA.bmp，在与BB.txt相同的工作表中插入BB.bmp？

Sub ExtractData()
iPath = "C:\Users\NHWD78\Desktop\Report\Radiated Immunity\"
ifile = Dir(iPath & "*.txt")

Do While Len(ifile)
Sheets.Add , Sheets(Sheets.Count), , iPath & ifile
ifile = Dir
Range("A10:B10, A16:B19").Copy Destination:=Sheets(Sheets.Count).Range("A1")

Application.CutCopyMode = False
Range("A6:K600").Clear
Columns.AutoFit

Loop
End Sub

我在整个网站上搜索，但只找到了一种插入带图像名称的固定图像的方法。

Answer 1

Worksheet.Shapes.AddPicture会这样做。示例如下： -

Public Sub Sample()
Dim WkBk    As Workbook
Dim WkSht   As Worksheet
Dim Ole     As Object

Set WkBk = ThisWorkbook
    Set WkSht = WkBk.Worksheets(1)
        WkSht.Shapes.AddPicture "C:\Users\garye\Desktop\AA.bmp", msoFalse, msoCTrue, 0, 0, -1, -1
    Set WkSht = Nothing
Set WkBk = Nothing

End Sub

Answer 2

这将回答您的问题，它更多的是一个解决方案，而不是一个不是本网站所针对的答案，而是花时间阅读它，因为它也应该在教育上有用。

您正在尝试解析内容类似于以下内容的文件夹： -

这些内容的结果是在Excel工作簿中，工作表包含每个组的文本和图像（AA，BB和CC）

我要采取的第一步是使用Microsoft Scripting Runtime，这使得解析文件夹变得更加容易。要在VBA环境（称为IDE）中启用此功能，请选择“工具”＆gt; '引用...'，向下滚动到'Microsoft Scripting Runtime'并勾选它，然后单击'确定'关闭对话框。

这允许我们使用文件系统对象，这是一个非常有用的文件和文件夹操作和询问功能集。

首先，我们最关心* .txt文件，所以让我们首先循环它们： -

Dim FSO     As New FileSystemObject
Dim Fldr    As Folder
Dim Fl      As File

'First we set Fldr to be the folder we care about
Set Fldr = FSO.GetFolder("C:\Users\garye\Desktop\Work")

    'Then start a loop to look through each file in the folder
    For Each Fl In Fldr.Files

        'If the files ends in .txt then we care about it (UCASE used to make it case insensitive)
        If Right(UCase(Fl.Name), 4) = ".TXT" Then

            'We have found a file

        End If

        'Do events returns the processor to the system for any other items to be process
        'very useful in a loop on a Windows based machine to stop resource hogging and lock ups
        DoEvents
    Next
Set Fldr = Nothing

接下来，在发现文本文件时，我们要创建工作表并导入文本。为了这个例子，它也将在一个新的工作簿中完成。

Dim WkBk        As Workbook
Dim WkBk_Tmp    As Workbook
Dim WkSht       As Worksheet
Dim WkSht_Tmp   As Worksheet
Dim StrName     As String

'Create a new workbook
Set WkBk = Application.Workbooks.Add

'...

'Collect the name (i.e. AA from AA.txt)
StrName = Left(Fl.Name, Len(Fl.Name) - 4)

'Create a new worksheet in out new workbook
Set WkSht = WkBk.Worksheets.Add

    'Change the worksheet name to the file name
    WkSht.Name = StrName

    'Open the file in Excel
    Set WkBk_Tmp = Application.Workbooks.Open(Fl.Path)
        Set WkSht_Tmp = WkBk_Tmp.Worksheets(1)

            'Copy its contents into out worksheet
            WkSht_Tmp.Cells.Copy WkSht.Cells
        Set WkSht_Tmp = Nothing

        'Close the file
        WkBk_Tmp.Close 0
    Set WkBk_Tmp = Nothing

接下来我们要插入图像，如果它在那里： -

Dim Rng         As Range

'...

'See it a bmp file exists (i.e. AA.bmp)
If FSO.FileExists(Fldr.Path & "\" & StrName & ".bmp") Then

    'This get the bottom row of data as a position to insert the image
    Set Rng = WkSht.Range(WkSht.Range("A1").End(xlDown).Address).Next(2, 0)

        'Add the picture
        WkSht.Shapes.AddPicture Fldr.Path & "\" & StrName & ".bmp", msoFalse, msoCTrue, Rng.Left, Rng.Top, -1, -1

    Set Rng = Nothing

 End If

如果我们把所有上述内容放在一起，它看起来如下所示，希望这是对代码中发生的事情，一些好的实践，如何处理任务的教育。

选项明确

Sub ExtractData()
Dim FSO         As New FileSystemObject
Dim Fldr        As Folder
Dim Fl          As File
Dim WkBk        As Workbook
Dim WkBk_Tmp    As Workbook
Dim WkSht       As Worksheet
Dim WkSht_Tmp   As Worksheet
Dim StrName     As String
Dim Rng         As Range

'Create a new workbook
Set WkBk = Application.Workbooks.Add

    'First we set Fldr to be the folder we care about
    Set Fldr = FSO.GetFolder("C:\Users\garye\Desktop\Work")

        'Then start a loop to look through each file in the folder
        For Each Fl In Fldr.Files

            'If the files ends in .txt then we care about it (UCASE used to make it case insensitive)
            If Right(UCase(Fl.Name), 4) = ".TXT" Then

                'Collect the name (i.e. AA from AA.txt)
                StrName = Left(Fl.Name, Len(Fl.Name) - 4)

                'Create a new worksheet in out new workbook
                Set WkSht = WkBk.Worksheets.Add

                    'Change the worksheet name to the file name
                    WkSht.Name = StrName

                    'Open the file in Excel
                    Set WkBk_Tmp = Application.Workbooks.Open(Fl.Path)
                        Set WkSht_Tmp = WkBk_Tmp.Worksheets(1)

                            'Copy its contents into out worksheet
                            WkSht_Tmp.Cells.Copy WkSht.Cells
                        Set WkSht_Tmp = Nothing

                        'Close the file
                        WkBk_Tmp.Close 0
                    Set WkBk_Tmp = Nothing

                    'See it a bmp file exists (i.e. AA.bmp)
                    If FSO.FileExists(Fldr.Path & "\" & StrName & ".bmp") Then

                        'This get the bottom row of data as a position to insert the image
                        Set Rng = WkSht.Range(WkSht.Range("A1").End(xlDown).Address).Next(2, 0)

                            'Add the picture
                            WkSht.Shapes.AddPicture Fldr.Path & "\" & StrName & ".bmp", msoFalse, msoCTrue, Rng.Left, Rng.Top, -1, -1

                        Set Rng = Nothing

                    End If

                Set WkSht = Nothing

            End If

            'Do events returns the processor to the system for any other items to be process
            'very useful in a loop on a Windows based machine to stop resource hogging and lock ups
            DoEvents
        Next
    Set Fldr = Nothing

Set WkBk = Nothing

MsgBox "Done!"

End Sub