The following script works just fine for me...
Sub ImportDataFromMultipleFiles()
Dim Filenames As Variant
Dim i As Integer
Application.ScreenUpdating = True
Range("B2").Select
Filenames = Application.GetOpenFilename(Filefilter:="Excel Filter (*.csv), *.csv", Title:="Open File(s)", MultiSelect:=True)
For i = 1 To UBound(Filenames)
Workbooks.Open Filenames(i)
Range("E1").Select
Selection.Copy
Windows("test.xlsm").Activate
Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=False
Workbooks.Open Filenames(i)
ActiveWorkbook.Close SaveChanges:=False
ActiveCell.Offset(1, 0).Activate
Next i
End Sub
The problem...Instead of "E1", I want CountA(E:E), but do not know how to get that to script properly and paste the result in the same manner as the above script, in reference to a single cell.
Okay...I partially figured out my own problem with the following script...
Sub ImportDataFromMultipleFiles()
Dim Filenames As Variant
Dim i As Integer
Application.ScreenUpdating = True
Range("B2").Select
Filenames = Application.GetOpenFilename(Filefilter:="Excel Filter (*.csv), *.csv", Title:="Open File(s)", MultiSelect:=True)
For i = 1 To UBound(Filenames)
Workbooks.Open Filenames(i)
Range("Z1").Select
ActiveCell.FormulaR1C1 = "=COUNTA(C[-21])"
Selection.Copy
Windows("test.xlsm").Activate
Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=False
Workbooks.Open Filenames(i)
ActiveWorkbook.Close SaveChanges:=False
ActiveCell.Offset(1, 0).Activate
Next i
End Sub
It opens each file, from the list selected, selects and empty cell on the selected file (Z1), performs a COUNTA on Column E that is displayed in Z1 and Z1 is copied and pasted in the desired location. Now, the problem is that it pauses every other cycle through the script. Any ideas???
Related
I have the following code I wrote in Excel:
Sub Multiple()
MyDir = ActiveWorkbook.Path
strPath = MyDir & ":"
strFile = Dir(strPath, MacID("TEXT"))
'Loop through each file in the folder
Do While Len(strFile) > 0
If Right(strFile, 3) = "csv" Then
Debug.Print strFile
DoWork (strFile)
End If
strFile = Dir
Loop
End Sub
Sub DoWork(wb As Workbook)
With wb
Range("E:E,K:K").Select
Range("K1").Activate
Selection.Delete Shift:=xlToLeft
ActiveSheet.Range("b1").End(xlDown).Select
ActiveCell.FormulaR1C1 = "=AVERAGE(R[-3]C:R[-1]C)/1000"
ActiveSheet.Range("b1").End(xlDown).Select
Selection.AutoFill Destination:=Range(ActiveCell, ActiveCell.Offset(0, 2)), Type:=xlFillDefault
ActiveSheet.Range("e1").End(xlDown).Select
ActiveCell.FormulaR1C1 = "=AVERAGE(R[-3]C:R[-1]C)"
ActiveSheet.Range("e1").End(xlDown).Select
Selection.AutoFill Destination:=Range(ActiveCell, ActiveCell.Offset(0, 4)), Type:=xlFillDefault
End With
End Sub
What I am trying to do is run the bottom Sub DoWork() which does some basic editing on an excel file on my macintosh on multiple files.
For that I wrote the uper Sub Multiple() which should eventually run the bottom Sub on multiple files.
The files type are CSV files.
The bottom code works perfect when running it individually on each Excel file.
However, the top code does not do the trick of running on all multiple files.
Anyone have an idea why?
In your Multiple code, you are passing a string parameter (the filename) to DoWork, but DoWork is expecting you to pass a Workbook object.
You will need to join strPath and strFile together (in Windows that would be strPath & "\" & strFile - I assume it will be something similar on a Mac) and then open the Workbook. I would suggest the following code should be used where you currently are just doing DoWork (strFile):
Set wb = Workbooks.Open(strPath & "\" & strFile) ' Adjust to suit for Mac filename syntax
DoWork wb
wb.Save
wb.Close False
Ok. Figured it out :-)
Sub Multiple()
Dim SecDir As String
Dim MyDir As String
Dim wbk As Workbook
MyDir = "tlv-mpzyw:Users:lcohen:Google Drive:SQA:Projects:vbaBotRegression:"
SecDir = "files:"
strPath = MyDir & SecDir
Debug.Print strPath
strFile = Dir(strPath)
'Loop through each file in the folder
Do While Len(strPath) > 0
If Right(strFile, 3) = "csv" Then
Debug.Print strFile
Set wbk = Workbooks.Open(Filename:=strPath & strFile)
Range("E:E,K:K").Select
Range("K1").Activate
Selection.Delete Shift:=xlToLeft
ActiveSheet.Range("b1").End(xlDown).Select
ActiveCell.FormulaR1C1 = "=AVERAGE(R[-3]C:R[-1]C)/1000"
ActiveSheet.Range("b1").End(xlDown).Select
Selection.AutoFill Destination:=Range(ActiveCell, ActiveCell.Offset(0, 2)), Type:=xlFillDefault
ActiveSheet.Range("e1").End(xlDown).Select
ActiveCell.FormulaR1C1 = "=AVERAGE(R[-3]C:R[-1]C)"
ActiveSheet.Range("e1").End(xlDown).Select
Selection.AutoFill Destination:=Range(ActiveCell, ActiveCell.Offset(0, 4)), Type:=xlFillDefault
wbk.Close SaveChanges:=False
End If
strFile = Dir
Loop
End Sub
Now I have another issue,
Am getting the following error message:
Run-time error '1004':
'TLV-MPZYW:USERS:LCOHEN:GOOGLE
DRIVE:SQA:PROJECTS:VBABOTREGRESSION:FILES:SAMPLES_MULTIPLE_FILTERS_QUERIES-STATISTICS.CSV'
could not be found.Check the spelling of the file name, and verify
that the file location is correct.
If you are trying to open the file from your list of most recently
used files on the File menu, make sure that the file has not been
renamed, moved, or deleted.
I am clueless at this point on what might be causing this issue.
As you can see in my code, I am printing the file name to verify that it indeed reads it correctly.
Anyone?????
I want to combine the functionalities of two codes. My first code is converting a csv file to an excel file and saving it with a different name.
I want to add a functionality of deleting the entire row in a file where column A is #N/A. There may be a small thing to fix it but I am not able to work
it out because I am not good at it.
file = "C:\PR\TEST\Sizetest.csv"
Set fso = CreateObject("Scripting.FileSystemObject")
txt = fso.OpenTextFile(file).ReadAll
fso.OpenTextFile(file, 2).Write Replace(Replace(txt, "¬", vbTab), Chr(34), "")
'Set obj = CreateObject("Scripting.FileSystemObject") 'Calls the File System Object
Const xlDelimited = 1
Const xlNormal = -4143
Dim Excel
Set Excel = CreateObject("Excel.Application")
With Excel
.Workbooks.Open "C:\PR\TEST\Sizetest.csv"
.Sheets(1).Columns("A").TextToColumns .Range("A1"), xlDelimited, , , , True 'semicolon-delimited
.ActiveWorkbook.SaveAs .ActiveWorkbook.Path & "\Size_test1", xlNormal
.Quit
' fso.DeleteFile("C:\PR\TEST\Sizetest.csv") 'Deletes the file throught the DeleteFile function
End With
This is the second code. This should delete entire row whereever there is #N/A in column A. I want the record to be deleted either before the file is
converted to Excel or after it is converted to Excel so it does not matter at what point it should convert it.
I got the following code by searching in the Google but due to not being good at VB script, I am not able to combine them two files. I tried different ways but I am getting one error or another.
Sub macro2()
Dim i As Long, lcol As Long
Application.DisplayAlerts = False
With Worksheets("Sheet1")
lcol = .Range("A1"). End(xLToRight).Column
For i = lcol To 1 Step -1
If.Cells(1, i).Value = "#N/A" Then .Rows(i).Delete
Next i
End With
Application.DisplayAlerts = True
End Sub
Thanks in advance
Updated Code Only to delete #N/A
Sub DeleteErrorRows()
'The path to the workbook in which to search.
'Defining the variables
Dim MyPath, MySheet,MyWB
MyPath = "C:\PR\TEST\Sizetest.xls"
'The name of the workbook in which to search.
MyWB = "SizeGuideLookup_test.xls"
'Use the current sheet as the place to store the data for which to search.
MySheet = ActiveSheet.Name
'If an error occurs, use the error handling routine at the end of this file.
'On Error GoTo ErrorHandler
'Turn off screen updating, and then open the target workbook.
'Application.ScreenUpdating = False
Const strERROR = "#N/A"
Application.ScreenUpdating = False
Dim i, lastRow, rw
Dim rFound
Dim sList
Workbooks.Open MyPath
'Workbooks.Open FileName:=MyPath & MyWB
set wb = Workbooks.Open(objFile.Mypath, ReadOnly:=True, CorruptLoad:=xlExtractData)
wb.Close
Set sList = CreateObject("System.Collections.Sortedlist")
Set rFound = ActiveSheet.Cells.Find(What:=strERROR, After:=Range("A1"), Lookat:=xlPart,LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If rFound Is Nothing Then Exit Sub
lastRow = rFound.Row
For i = 1 To lastRow
Set rFound = Rows(i).Find(What :=strERROR, After:=Rows(i).Cells(1, Columns.Count), Lookat:=xlPart, _
LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not rFound Is Nothing Then
If Not sList.ContainsKey(i) Then
sList.Add i, vbNullString
End If
End If
Next
For i = sList.Count - 1 To 0 Step -1
rw = sList.GetKey(i)
Rows(rw).Delete
Next
DeleteErrorRows
Application.ScreenUpdating = True
'conn.close
End Sub
I am getting error on the following line of code. Error says 'Expected End of Statement )' This code seems ok to me. There might be other errors and I am trying to get this program to work. Set rFound = ActiveSheet.Cells.Find(What:=strERROR, After:=Range("A1"), Lookat:=xlPart,LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
Delete all Rows with a #N/A Error from an Excel Worksheet using either VBA or VBScript
Sub RemoveErrorRows(oWorksheet)
Const strERROR = "#N/A"
Const xlValues = -4163
Const xlPart = 2
Const xlByRows = 1
Const xlNext = 1
Dim rFound, lastRow, x
With oWorksheet
Do
Set rFound = .Rows.Find(CStr(strERROR), .UsedRange.Cells(1, .Columns.Count), xlValues, xlPart, xlByRows, xlNext)
If rFound Is Nothing Then
Exit Do
Else
.Rows(rFound.Row).Delete
End If
Loop
End With
End Sub
I have a code which I would like to use on multiple sheets, except one sheet. But applying the code to alle sheets is also fine.
Here is the code that I would like to adjust. I am have currently applied it to Excel 2011 in OS X , but I would like to use it for Excel 2010 in Windows.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
Dim the_selection As String
Dim month_in_review As String
the_selection = Sheet1.Range("A1")
Dim Rep As Integer
For Rep = 2 To 379
the_column = GetColumnLetter_ByInteger(Rep)
month_in_review = Sheet1.Range(the_column & "1")
If the_selection = month_in_review Then
Sheet1.Range(the_column & ":" & the_column).EntireColumn.Hidden = False
Else
Sheet1.Range(the_column & ":" & the_column).EntireColumn.Hidden = True
End If
Next Rep
End If
End Sub
In the module I have the following code:
Public Function GetColumnLetter_ByInteger(what_number As Integer) As String
GetColumnLetter_ByInteger = ""
MyColumn_Integer = what_number
If MyColumn_Ineger <= 26 Then
column_letter = ChrW(64 + MyColumn_Integer)
End If
If MyColumn_Integer > 26 Then
column_letter = ChrW(Int((MyColumn_Integer - 1) / 26) + 64) & ChrW(((MyColumn_Integer - 1) Mod 26) + 65)
End If
GetColumnLetter_ByInteger = column_letter
End Function
If you're asking for one sheet to detect the change in cell "A1" and then to hide/unhide columns on multiple sheets then the prior answers to your question will serve you nicely.
If, on the other hand, you're asking to detect a change in cell "A1" on any sheet and then to hide/unhide columns on just the changed sheet, then the code below will work for you. It accesses the Workbook_SheetChanged event at Workbook level.
A few points about your code:
You can reference cells using their integer or address values with the .Cell property, so Sheet1.Cells(1, 1) is the same as Sheet1.Cells(1, "A"). The same applies to the .Columns property. So there's no real need to convert your integer values to a string. See #Florent B's answer for a good example of this.
Wherever possible, minimise looping sheet interactions as these are very time-consuming. So rather than loop through the columns and hide/unhide each one individually, you could assign them to ranges within your loop and then hide/unhide the ranges all in one go at the end of your loop. If you must interact with the sheet on each iteration of your loop, then set the Application.ScreenUpdating property to false before the start of your loop. There's an example of this property in the sample code below.
Put this in your Workbook module:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Const TARGET_ADDRESS As String = "A1"
Dim cell As Range
Dim hiddenCols As Range
Dim unhiddenCols As Range
Dim selectedMonth As String
Dim monthInReview As String
Dim c As Integer
'Ignore event if not a target worksheet
If Sh.Name = "Not Wanted" Then Exit Sub
'Ignore event if not in target range
Set cell = Target.Cells(1)
If cell.Address(False, False) <> TARGET_ADDRESS Then Exit Sub
'Criteria met, so handle event
selectedMonth = CStr(cell.Value)
For c = 2 To 379
Set cell = Sh.Cells(1, c)
monthInReview = CStr(cell.Value)
'Add cell to hidden or unhidden ranges
If monthInReview = selectedMonth Then
If unhiddenCols Is Nothing Then
Set unhiddenCols = cell
Else
Set unhiddenCols = Union(unhiddenCols, cell)
End If
Else
If hiddenCols Is Nothing Then
Set hiddenCols = cell
Else
Set hiddenCols = Union(hiddenCols, cell)
End If
End If
Next
'Hide and unhide the cells
Application.ScreenUpdating = False 'not really needed here but given as example
If Not unhiddenCols Is Nothing Then
unhiddenCols.EntireColumn.Hidden = False
End If
If Not hiddenCols Is Nothing Then
hiddenCols.EntireColumn.Hidden = True
End If
Application.ScreenUpdating = True
End Sub
You can use a for each loop to loop through all the Worksheets, and check the worksheet name if it should be skipped. Then apply your code onto the sheet selected.
Something like:
Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Skip Sheet" Then
Dim the_selection As String
Dim month_in_review As String
the_selection = ws.Range("A1")
Dim Rep As Integer
For Rep = 2 To 379
the_column = GetColumnLetter_ByInteger(Rep)
month_in_review = ws.Range(the_column & "1")
If the_selection = month_in_review Then
ws.Range(the_column & ":" & the_column).EntireColumn.Hidden = False
Else
ws.Range(the_column & ":" & the_column).EntireColumn.Hidden = True
End If
Next Rep
End If
Next ws
End If
End Sub
I wasn't entirely sure what you wished to achieve, so i put ws in the place of Sheet1.
This example will show/hide the columns in all the other sheets if the first cell of the column match/differ with the cell A1 of the sheet where this code is placed:
Private Sub Worksheet_Change(ByVal Target As Range)
' exit if not cell A1
If Target.row <> 1 Or Target.column <> 1 Then Exit Sub
Dim sheet As Worksheet
Dim the_selection As String
Dim month_in_review As String
Dim column As Integer
the_selection = Target.Value
' iterate all the sheets
For Each sheet In ThisWorkbook.Worksheets
' skip this sheet
If Not sheet Is Me Then
' iterate the columns
For column = 2 To 379
' get the first cell of the column
month_in_review = sheet.Cells(1, column).Value
' hide or show the column if it's a match or not
sheet.Columns(column).Hidden = month_in_review <> the_selection
Next
End If
Next
End Sub
This sub removes all command buttons and their associated rows that were created programmatically on a sheet. It takes around 20 seconds to remove 60 command buttons and rows. I've stepped through it and can find no problems with it.
Sub ResetForm_Click()
Dim Contr
Dim controlname As String
Dim WS As Worksheet
Set WS = ActiveSheet
For Each Contr In WS.OLEObjects
controlname = Mid(Contr.Name, 1, 2)
If controlname = "CB" Then
Contr.TopLeftCell.Rows.EntireRow.Delete
Contr.Delete
End If
Next
End Sub
Instead of deleting rows one-by-one try something like this (untested):
Sub ResetForm_Click()
Dim Contr
Dim controlname As String
Dim WS As Worksheet, rDel As Range
Set WS = ActiveSheet
For Each Contr In WS.OLEObjects
controlname = Mid(Contr.Name, 1, 2)
If controlname = "CB" Then
If rDel Is Nothing then
Set rDel = Contr.TopLeftCell
Else
Set rDel = Application.Union(rDel, Contr.TopLeftCell)
End If
Contr.Delete
End If
Next
If Not rDel Is Nothing then rDel.EntireRow.Delete
End Sub
Without editing your macro too much, turn off screen updating and autocalculation, see if that helps.
At the beginning of your macro (I usually put it after my declarations), add
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Then at the end (before End Sub), turn them back on
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
I have an Excel file which includes pictures in column B and I want like to export them into several files as .jpg (or any other picture file format). The name of the file should be generated from text in column A. I tried following VBA macro:
Private Sub CommandButton1_Click()
Dim oTxt As Object
For Each cell In Ark1.Range("A1:A" & Ark1.UsedRange.Rows.Count)
' you can change the sheet1 to your own choice
saveText = cell.Text
Open "H:\Webshop_Zpider\Strukturbildene\" & saveText & ".jpg" For Output As #1
Print #1, cell.Offset(0, 1).text
Close #1
Next cell
End Sub
The result is that it generates files (jpg), without any content. I assume the line Print #1, cell.Offset(0, 1).text. is wrong.
I don't know what I need to change it into, cell.Offset(0, 1).pix?
Can anybody help me? Thanks!
If i remember correctly, you need to use the "Shapes" property of your sheet.
Each Shape object has a TopLeftCell and BottomRightCell attributes that tell you the position of the image.
Here's a piece of code i used a while ago, roughly adapted to your needs. I don't remember the specifics about all those ChartObjects and whatnot, but here it is:
For Each oShape In ActiveSheet.Shapes
strImageName = ActiveSheet.Cells(oShape.TopLeftCell.Row, 1).Value
oShape.Select
'Picture format initialization
Selection.ShapeRange.PictureFormat.Contrast = 0.5: Selection.ShapeRange.PictureFormat.Brightness = 0.5: Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic: Selection.ShapeRange.PictureFormat.TransparentBackground = msoFalse: Selection.ShapeRange.Fill.Visible = msoFalse: Selection.ShapeRange.Line.Visible = msoFalse: Selection.ShapeRange.Rotation = 0#: Selection.ShapeRange.PictureFormat.CropLeft = 0#: Selection.ShapeRange.PictureFormat.CropRight = 0#: Selection.ShapeRange.PictureFormat.CropTop = 0#: Selection.ShapeRange.PictureFormat.CropBottom = 0#: Selection.ShapeRange.ScaleHeight 1#, msoTrue, msoScaleFromTopLeft: Selection.ShapeRange.ScaleWidth 1#, msoTrue, msoScaleFromTopLeft
'/Picture format initialization
Application.Selection.CopyPicture
Set oDia = ActiveSheet.ChartObjects.Add(0, 0, oShape.Width, oShape.Height)
Set oChartArea = oDia.Chart
oDia.Activate
With oChartArea
.ChartArea.Select
.Paste
.Export ("H:\Webshop_Zpider\Strukturbildene\" & strImageName & ".jpg")
End With
oDia.Delete 'oChartArea.Delete
Next
This code:
Option Explicit
Sub ExportMyPicture()
Dim MyChart As String, MyPicture As String
Dim PicWidth As Long, PicHeight As Long
Application.ScreenUpdating = False
On Error GoTo Finish
MyPicture = Selection.Name
With Selection
PicHeight = .ShapeRange.Height
PicWidth = .ShapeRange.Width
End With
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet1"
Selection.Border.LineStyle = 0
MyChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)
With ActiveSheet
With .Shapes(MyChart)
.Width = PicWidth
.Height = PicHeight
End With
.Shapes(MyPicture).Copy
With ActiveChart
.ChartArea.Select
.Paste
End With
.ChartObjects(1).Chart.Export Filename:="MyPic.jpg", FilterName:="jpg"
.Shapes(MyChart).Cut
End With
Application.ScreenUpdating = True
Exit Sub
Finish:
MsgBox "You must select a picture"
End Sub
was copied directly from here, and works beautifully for the cases I tested.
''' Set Range you want to export to the folder
Workbooks("your workbook name").Sheets("yoursheet name").Select
Dim rgExp As Range: Set rgExp = Range("A1:H31")
''' Copy range as picture onto Clipboard
rgExp.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
''' Create an empty chart with exact size of range copied
With ActiveSheet.ChartObjects.Add(Left:=rgExp.Left, Top:=rgExp.Top, _
Width:=rgExp.Width, Height:=rgExp.Height)
.Name = "ChartVolumeMetricsDevEXPORT"
.Activate
End With
''' Paste into chart area, export to file, delete chart.
ActiveChart.Paste
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Chart.Export "C:\ExportmyChart.jpg"
ActiveSheet.ChartObjects("ChartVolumeMetricsDevEXPORT").Delete
Dim filepath as string
Sheets("Sheet 1").ChartObjects("Chart 1").Chart.Export filepath & "Name.jpg"
Slimmed down the code to the absolute minimum if needed.
New versions of excel have made old answers obsolete. It took a long time to make this, but it does a pretty good job. Note that the maximum image size is limited and the aspect ratio is ever so slightly off, as I was not able to perfectly optimize the reshaping math. Note that I've named one of my worksheets wsTMP, you can replace it with Sheet1 or the like. Takes about 1 second to print the screenshot to target path.
Option Explicit
Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Sub weGucciFam()
Dim tmp As Variant, str As String, h As Double, w As Double
Application.PrintCommunication = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
If Application.StatusBar = False Then Application.StatusBar = "EVENTS DISABLED"
keybd_event vbKeyMenu, 0, 0, 0 'these do just active window
keybd_event vbKeySnapshot, 0, 0, 0
keybd_event vbKeySnapshot, 0, 2, 0
keybd_event vbKeyMenu, 0, 2, 0 'sendkeys alt+printscreen doesn't work
wsTMP.Paste
DoEvents
Const dw As Double = 1186.56
Const dh As Double = 755.28
str = "C:\Users\YOURUSERNAMEHERE\Desktop\Screenshot.jpeg"
w = wsTMP.Shapes(1).Width
h = wsTMP.Shapes(1).Height
Application.DisplayAlerts = False
Set tmp = Charts.Add
On Error Resume Next
With tmp
.PageSetup.PaperSize = xlPaper11x17
.PageSetup.TopMargin = IIf(w > dw, dh - dw * h / w, dh - h) + 28
.PageSetup.BottomMargin = 0
.PageSetup.RightMargin = IIf(h > dh, dw - dh * w / h, dw - w) + 36
.PageSetup.LeftMargin = 0
.PageSetup.HeaderMargin = 0
.PageSetup.FooterMargin = 0
.SeriesCollection(1).Delete
DoEvents
.Paste
DoEvents
.Export Filename:=str, Filtername:="jpeg"
.Delete
End With
On Error GoTo 0
Do Until wsTMP.Shapes.Count < 1
wsTMP.Shapes(1).Delete
Loop
Application.PrintCommunication = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
Thanks for the ideas! I used the above ideas to make a macro to do a bulk file conversion--convert every file of one format in a folder to another format.
This code requires a sheet with cells named "FilePath" (which must end in a "\"), "StartExt" (original file extension), and "EndExt" (desired file extension). Warning: it doesn't ask for confirmation before replacing existing files with the same name and extension.
Private Sub CommandButton1_Click()
Dim path As String
Dim pathExt As String
Dim file As String
Dim oldExt As String
Dim newExt As String
Dim newFile As String
Dim shp As Picture
Dim chrt As ChartObject
Dim chrtArea As Chart
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Get settings entered by user
path = Range("FilePath")
oldExt = Range("StartExt")
pathExt = path & "*." & oldExt
newExt = Range("EndExt")
file = Dir(pathExt)
Do While Not file = "" 'cycle through all images in folder of selected format
Set shp = ActiveSheet.Pictures.Insert(path & file) 'Import image
newFile = Replace(file, "." & oldExt, "." & newExt) 'Determine new file name
Set chrt = ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height) 'Create blank chart for embedding image
Set chrtArea = chrt.Chart
shp.CopyPicture 'Copy image to clipboard
With chrtArea 'Paste image to chart, then export
.ChartArea.Select
.Paste
.Export (path & newFile)
End With
chrt.Delete 'Delete chart
shp.Delete 'Delete imported image
file = Dir 'Advance to next file
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Here is another cool way to do it- using en external viewer that accepts command line switches (IrfanView in this case) :
* I based the loop on what Michal Krzych has written above.
Sub ExportPicturesToFiles()
Const saveSceenshotTo As String = "C:\temp\"
Const pictureFormat As String = ".jpg"
Dim pic As Shape
Dim sFileName As String
Dim i As Long
i = 1
For Each pic In ActiveSheet.Shapes
pic.Copy
sFileName = saveSceenshotTo & Range("A" & i).Text & pictureFormat
Call ExportPicWithIfran(sFileName)
i = i + 1
Next
End Sub
Public Sub ExportPicWithIfran(sSaveAsPath As String)
Const sIfranPath As String = "C:\Program Files\IrfanView\i_view32.exe"
Dim sRunIfran As String
sRunIfran = sIfranPath & " /clippaste /convert=" & _
sSaveAsPath & " /killmesoftly"
' Shell is no good here. If you have more than 1 pic, it will
' mess things up (pics will over run other pics, becuase Shell does
' not make vba wait for the script to finish).
' Shell sRunIfran, vbHide
' Correct way (it will now wait for the batch to finish):
call MyShell(sRunIfran )
End Sub
Edit:
Private Sub MyShell(strShell As String)
' based on:
' http://stackoverflow.com/questions/15951837/excel-vba-wait-for-shell-command-to-complete
' by Nate Hekman
Dim wsh As Object
Dim waitOnReturn As Boolean:
Dim windowStyle As VbAppWinStyle
Set wsh = VBA.CreateObject("WScript.Shell")
waitOnReturn = True
windowStyle = vbHide
wsh.Run strShell, windowStyle, waitOnReturn
End Sub