Merge multiple csv files in one excel sheet - excel

After searching a lot on the internet i tried to combine a working Excel VBA code that reads all .csv files in a folder into an excel file (each on a seperate worksheet).
But the only thing i need is to combine all the csv files in 1 worksheet....
The working code is:
working file into seperate worksheets
Sub Example12()
Dim MyPath As String
Dim FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long
Dim Fnum As Long
Dim mybook As Workbook
Dim basebook As Workbook
'Fill in the path\folder where the files are
'on your machine
MyPath = "c:\Data"
'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 & "*.csv")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
On Error GoTo CleanUp
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
'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
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
mybook.Worksheets(1).Copy after:= _
basebook.Sheets(basebook.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = mybook.Name
On Error GoTo 0
' You can use this if you want to copy only the values
' With ActiveSheet.UsedRange
' .Value = .Value
' End With
mybook.Close savechanges:=False
Next Fnum
End If
CleanUp:
Application.ScreenUpdating = True
End Sub
---------------------------------------------------------
But the change i've made was to change the part where the VBA copies it into a sheet "after" the last one, to append it to a existing sheet "Totaal".
not working code
---------------------------------------------------------
Sub Example12()
Dim MyPath As String
Dim FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long
Dim Fnum As Long
Dim mybook As Workbook
Dim basebook As Workbook
'Fill in the path\folder where the files are
'on your machine
MyPath = "c:\Data"
'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 & "*.csv")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
On Error GoTo CleanUp
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
'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
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
mybook.Worksheets(1).Copy
**basebook.Sheets("Totaal").Select
NextRow = Cells(Rows.Count, 0).End(xlUp).Row
Cells(NextRow, 1).Select
ActiveSheet.Paste**
On Error Resume Next
ActiveSheet.Name = mybook.Name
On Error GoTo 0
' You can use this if you want to copy only the values
' With ActiveSheet.UsedRange.Value = .Value
' End With
mybook.Close savechanges:=False
Next Fnum
End If
CleanUp:
Application.ScreenUpdating = True
End Sub
I haven't got the knowledge to change this :(.
Was I on the right track?
All input will be greatly appreciated!
EXTRA INFO: The data in the CSV files are put in the first column. After the whole merging process i planned to do the split into columns afterwards....
Thanks!

After Set basebook = ThisWorkbook
Enter this:
Dim nextRow As Integer
Dim wsTotal As Worksheet
Set wsTotal = basebook.Worksheets("Total")
And here is the corrected For loop:
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
'open file
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
With wsTotal
'activate if you want (optional)
'.Activate
'copy all the data on the sheet
mybook.Worksheets(1).UsedRange.Copy
'find the next empty row
nextRow = .Range("A1").SpecialCells(xlCellTypeLastCell).Row + 1
'select if desired (optional)
'.Cells(NextRow, 1).Select
'paste the data
.Cells(nextRow, 1).PasteSpecial (xlPasteAll)
'turn off copy mode
Application.CutCopyMode = False
'Do you really want to change the worksheet name?
.Name = mybook.Name
End With
'close file
mybook.Close savechanges:=False
Next Fnum

To import csv files I would suggest using a query instead of opening them. This way, you can also perform the data-to-columns split on-the-go :
Sub ImportToNewWorksheet(ImpFileName as String)
Dim mySheet As Worksheet
Set mySheet = ThisWorkbook.Worksheets.Add
Call ImportFile(ImpFileName, mySheet.Cells(1,1))
End Sub
Sub ImportFile(ImpFileName As String, ImpDest As Range)
With ImpDest.Worksheet.QueryTables.Add(Connection:= _
"TEXT;" & ImpFileName, Destination:=ImpDest)
.Name = "Import"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 65001
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub

Related

VBA: save Excel files as PDF

VBA to save files as PDF.
Please help me with the following Excel Macro. I currently have it set up as if given a specific folder. It will either convert all the excel (.xsl) inside the folder into PDF. Right now, I was able to either the active/selected sheet or all of them. Please see current code below:
Sub Convert_Excel_To_PDF()
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
Dim LPosition As Integer
'Fill in the path\folder where the Excel files are
MyPath = "C:\downloads\example_test\"
FilesInPath = Dir(MyPath & "*.xls*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
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
LPosition = InStr(1, mybook.Name, ".") - 1
mybookname = Left(mybook.Name, LPosition)
mybook.Activate
'All PDF Files get saved in the directory below:
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\downloads\example_test\" & mybookname & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
End If
mybook.Close SaveChanges:=False
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
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
I am trying to do it so that based on a table (with the name "sheet_select_table1"), it does a lookup of the name, and if it matches column A, then only use the sheet on column B and convert such specific sheet number into PDF.
For example:
If there is a file with the name "04-file1.xls" it would go through the given path and only turn into PDF sheet 1. Similarly, if there is a file "08-test2.xlsx" it would only turn into PDF sheet 2.
Also, just to clarify, the macro_file.xslm will be the one running to convert other excel files (in the given folder) into PDFs. There will be no content in the macro file other than the table indicated above, so there is no need to convert it into PDF.
If the files do not match the name, import all the sheets (which is what it is currently doing).
I think it would have to have an IF function to go over the table.
Any help is appreciated!
Please let me know if anything needs further clarification; again, thank you in advance!
This should do what you want. Feel free to change the code to suit your needs.
Sub Convert_Excel_To_PDF()
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
Dim LPosition As Integer
'Fill in the path\folder where the Excel files are
MyPath = "C:\Users\ryans\Desktop\in\"
FilesInPath = Dir(MyPath & "*.xls*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
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
LPosition = InStr(1, mybook.Name, ".") - 1
mybookname = Left(mybook.Name, LPosition)
mybook.Activate
'All XLSX Files get saved in the directory below:
ActiveWorkbook.SaveAs Filename:="C:\Users\ryans\Desktop\out\" & mybookname & ".pdf"
End If
mybook.Close SaveChanges:=False
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
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub

Combine multiple workbooks in a folder into one file, every workbook as a separate sheet, file name = sheet name - Excel VBA macro

I have a folder with many Excel workbooks (technical reports, every workbook has just a single sheet named Sheet) and I need to do a summary workbook where every workbook (report) from the folder will be inserted as a single worksheet that will be named with it´s file name from the folder.
I have this two-part code that first renames sheets in workbooks (reports) in stated in the code folder (would be better a pop-up window) and then opens a pop-up window to select the folder where the files (reports) to combine are.
Is there a way to do everything automatically at once?
Also in the following code I have a problem with file names with dots ".", eg. for a report BAHU76 -CL19.1.1- it just gives a name BAHU76 -CL19
Thank you in advance for your help!
Sub RenSheets()
Dim MyFolder As String
Dim MyFile As String
Dim wbname As String
MyFolder = "C:\excel"
MyFile = Dir(MyFolder & "\*.xlsx")
Application.ScreenUpdating = False
Do While MyFile <> ""
Workbooks.Open Filename:=MyFolder & "\" & MyFile
With ActiveWorkbook
wbname = Left(.Name, InStr(.Name, ".") - 1)
.Sheets(1).Name = wbname
.Close savechanges:=True
End With
MyFile = Dir
Loop
Application.ScreenUpdating = True
Dim fnameList, fnameCurFile As Variant
Dim countFiles, countSheets As Integer
Dim wksCurSheet As Worksheet
Dim wbkCurBook, wbkSrcBook As Workbook
fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
If (vbBoolean <> VarType(fnameList)) Then
If (UBound(fnameList) > 0) Then
countFiles = 0
countSheets = 0
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wbkCurBook = ActiveWorkbook
For Each fnameCurFile In fnameList
countFiles = countFiles + 1
Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
For Each wksCurSheet In wbkSrcBook.Sheets
countSheets = countSheets + 1
wksCurSheet.Copy After:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
wbkCurBook.Sheets(wbkCurBook.Sheets.Count).Name = Left(wksCurSheet.Name, 31)
Next
wbkSrcBook.Close savechanges:=False
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Procesed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
End If
Else
MsgBox "No files selected", Title:="Merge Excel files"
End If
End Sub
Something like this may help you.
Sub Basic_Example_1()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, Fnum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
'Fill in the path\folder where the files are
MyPath = "C:\your_path_here\"
'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
'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1
'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
On Error Resume Next
With mybook.Worksheets(1)
Set sourceRange = .Range("A1:J100")
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all columns then skip this file
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
SourceRcount = sourceRange.Rows.Count
If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "Sorry there are not enough rows in the sheet"
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else
'Copy the file name in column A
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = MyFiles(Fnum)
End With
'Set the destrange
Set destrange = BaseWks.Range("B" & rnum)
'we copy the values from the sourceRange to the destrange
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If
Next Fnum
BaseWks.Columns.AutoFit
End If
ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
Of course, you can use a dynamic range, instead of a fixed range. Check out the link below for more info on this concept.
https://www.rondebruin.nl/win/s3/win010.htm

Unmerging all Cells in Many Workbooks in Certain Folder Path

Here is the code am using but unfortunately its not working
am using excel 365 and windows 10
it gets stuck on excel interface with no errors showing and no action or processing and no file is open
Please help me find a solution or provide me with a ready made Excel VBA macro for doing the same task as I a use an old erp that exports its reports into htm then i convert them into excel and then have to merge all cells in order to work with them efficiently.
Sub UnmergeAllCellsinWorkbooksinOneFolder()
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 = "F:\Sales Rates"
'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 & "*.xlsx*")
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.Worksheets(1)
sh.Cells.MergeCells = False
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
End Sub
sh is nothing. I think it should be fixed as below.
With mybook.Worksheets(1)
'sh.Cells.MergeCells = False
.Cells.MergeCells = False
End With

finding values from several workbooks using the directory

I want to copy data from several workbooks
the directory of the workbooks have order like this
c:\sheets\#number #month\worksheet #date
I would like to copy the same range in all workbooks
The month format is MMM
The date format us DD-MMM-YYYY
This will do what you want.
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 = "C:\your_path_here\"
'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
' do your copy process here ...
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
End Sub
https://www.rondebruin.nl/win/s3/win010.htm

How to insert and offset an image based on cell value

I'm facing a bit of an issue.
We needed to make a small, single cell, change to about a 1000 client statements (excel). I ran the change in python using openpyxl and all the company logos disappeared.
I have compiled a VBA to put the images back but am struggling with getting them in the right position on the second page as the top of the second page is not a set row number.
However, the clients name marks the top of the second page.
Is there a way I can search column B for the clients name and insert the companies logo in the same row but 9 columns to the right.
This is what I have so far:
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
End Sub
You could use:
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

Resources