Related
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 made a code on my Windows PC, have multiple macro's/VBA's but made the file for somebody with an Mac.
not sure where to start with adjusting code, but has anyone a clue how the following problems are caused, this will help me with finding a solution.. I probably used windows specific components..
if somebody can push me in the right direction, it would be great.. Have found a few topics:
http://www.vbaexpress.com/forum/archive/index.php/t-12976.html
and this one probably has the solution for my PDF problem:
Excel VBA code to work on Mac, Create PDF Function
Problem 1: colomnwidth doesn't work:
End With
Columns("A:A").EntireColumn.AutoFit
Columns("A:A").ColumnWidth = 26
Columns("C:H").Select
Selection.ColumnWidth = 4.5
Columns("J:L").Select
Selection.ColumnWidth = 11.5
Columns("I:I").Select
Selection.ColumnWidth = 16.25
Columns("B:B").ColumnWidth = 11.5
Columns("J:L").Select
Selection.ColumnWidth = 10.25
Columns("I:I").EntireColumn.AutoFit
Button to make PDF gives "Could not Create PDF"
Sub SaveConcept()
Dim ws As Worksheet
Dim strPath As String
Dim myFile As Variant
Dim strFile As String
On Error GoTo errHandler
Range("N8:N9").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5287936
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ActiveSheet.PageSetup.Orientation = xlLandscape
Set ws = ActiveSheet
strFile = Range("J15") _
& Format(Now(), " dd-mm-yyyy") _
& Format(" Concept") _
& ".pdf"
strFile = ThisWorkbook.Path & "\" & strFile
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
If myFile <> "False" Then
ActiveSheet.Range("L1", _
ActiveSheet.Range("L1").End(xlDown).End(xlDown).End(xlDown).End(xlToLeft).End(xlToLeft).End(xlToLeft).End(xlDown)).ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
End Sub
thanks
There shouldn't be an issue with the first part+ as it's nothing specific to windows, for the second part - you're using "\" as the path separator for the PDF file, on a Mac this is typically ":"
To make the code compatible for both, use the application value instead:
strFile = ThisWorkbook.Path & Application.PathSeparator & strFile
+note: this was OP code at time of answer
In my master workbook I have 1 table in each one of my 4 sheets and in sheet2 and sheet4 I have a couple of columns with IF and VLOOKUP functions at the right of the table.
I am trying to do the following:Clear content from the 4 tables while maintaining only one row of formulas (in sheet 2 and 4), Copy the range I want from a table in sheet1 of another workbook (repeat for other sheets), And paste into the table of sheet1 of master workbook (repeat for other sheets), Autofill the formulas of the remanining columns (only in sheet 2 and 4).
While the code does it's job, it takes almost 2 hours to perform this task! Even the Clearcontent of sheet2 takes 8 minutes for just 250 rows which seems ridiculous long time! Sheet1 has 1000 rows, sheet2 has 250, sheet3 has 1000, sheet4 has 26k rows.
Code seems too big for what it does. What can I do to optimise and speed up the code? Any viable work around or is this normal? I have tried Application.Calculation = xlCalculationManual but no improvement.
Sub LoopThroughDirectory()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim MyFile As String
Dim erow1
Dim erow2
Dim erow3
Dim erow4
Dim Filepath As String
Dim wkb As Workbook
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim sht3 As Worksheet
Dim sht4 As Worksheet
Dim ero2 As Long
Dim ero4 As Long
Dim lastero1 As Long
Dim lastero2 As Long
Dim lastero3 As Long
Dim lastero4 As Long
Folha1.Activate
Folha1.Range(Cells(3, 1), Cells(99999, 173)).ClearContents
Folha1.Range(Cells(2, 1), Cells(99999, 173)).ClearContents
Folha2.Activate
Folha2.Range(Cells(3, 1), Cells(99999, 150)).ClearContents
Folha2.Range(Cells(2, 1), Cells(99999, 137)).ClearContents
Folha3.Activate
Folha3.Range(Cells(3, 1), Cells(99999, 197)).ClearContents
Folha3.Range(Cells(2, 1), Cells(99999, 197)).ClearContents
Folha4.Activate
Folha4.Range(Cells(3, 1), Cells(99999, 152)).ClearContents
Folha4.Range(Cells(2, 1), Cells(99999, 108)).ClearContents
Filepath = "C:\Users\carlos\Downloads\Projectos\Teste\"
MyFile = Dir(Filepath)
Do While MyFile = "Dados Projectos New"
If MyFile = "Dados Projectos_Master.xlsm" Then
Exit Sub
End If
Set wkb = Workbooks.Open(Filepath & MyFile)
Set sht1 = wkb.Sheets("Encomendas")
Set sht2 = wkb.Sheets("Projectos")
Set sht3 = wkb.Sheets("Casos")
Set sht4 = wkb.Sheets("Actividades Serviço")
wkb.Activate
sht1.Activate
With Sheets("Encomendas") 'Last row of the first sheet I want to copy
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastero1 = .Range("A:fq").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
Range("a2:fq" & lastero1).Copy
Folha1.Activate
'last row of the first sheet of master workbook I want to paste
erow1 = Folha1.Cells.Find("*", After:=Range(Cells(Rows.Count, 173), Cells(Rows.Count, 173)), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
ThisWorkbook.ActiveSheet.Paste Destination:=Worksheets("Encomendas").Range(Cells(erow1 + 1, 1), Cells(erow1 + 1, 173))
wkb.Activate
sht2.Activate
With Sheets("Projectos") 'Last row of the second sheet I want to copy
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastero2 = .Range("A:EG").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
Range("a2:Eg" & lastero2).Copy
Folha2.Activate
With Sheets("Projectos") 'Last row of the second sheet of master workbook I want to paste
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
erow2 = .Range("A:EG").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
ThisWorkbook.ActiveSheet.Paste Destination:=Worksheets("Projectos").Range(Cells(erow2 + 1, 1), Cells(erow2 + 1, 137))
With Sheets("Projectos") 'Last row of the second sheet of master workbook I want to autofill
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
ero2 = .Range("A:EG").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
Range("EH2:ET2").AutoFill Destination:=Range("EH2:ET" & ero2)
wkb.Activate
sht3.Activate
With Sheets("Casos") 'Last row of the third sheet I want to copy
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastero3 = .Range("A:go").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
Range("a2:go" & lastero3).Copy
'Last row of the third sheet of master workbook I want to paste
erow3 = Folha3.Cells.Find("*", After:=Range(Cells(Rows.Count, 197), Cells(Rows.Count, 197)), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Folha3.Activate
ThisWorkbook.ActiveSheet.Paste Destination:=Worksheets("Casos").Range(Cells(erow3 + 1, 1), Cells(erow3 + 1, 197))
wkb.Activate
sht4.Activate
With Sheets("Actividades Serviço") 'Last row of the fourth sheet I want to copy
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lastero4 = .Range("A:dd").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
Range("a2:dd" & lastero4).Copy
ActiveWorkbook.Close
Folha4.Activate
With Sheets("Actividades serviço") 'Last row of the fourth sheet of master workbook I want to paste
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
erow4 = .Range("A:DD").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
ThisWorkbook.ActiveSheet.Paste Destination:=Worksheets("Actividades serviço").Range(Cells(erow4 + 1, 1), Cells(erow4 + 1, 108))
With Sheets("Actividades serviço") 'Last row of the fourth sheet of master workbook I want to autofill
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
ero4 = .Range("A:DD").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
End With
Range("de2:EV2").AutoFill Destination:=Range("de2:Ev" & ero4)
MyFile = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Issues I see so far:
Folha1.Activate
Folha1.Range(Cells(3, 1), Cells(99999, 173)).ClearContents
Folha1.Range(Cells(2, 1), Cells(99999, 173)).ClearContents
You don’t need to activate since youre quite literally telling it where to clear contents.
Range("a2:fq" & lastero1).Copy
No need to copy, you can literally saying something like “Range(“a1”).Value = Range(“C2”).Value. This also means by extension that you don’t have to paste as well.
Some of the major performance tips for macros suggest not to “Copy/Paste” as well as try to avoid “selecting” and “activating.” In fact, directly manipulating worksheets is often seen as cardinal sin.
With larger data sets that need to be moved around, storing everything in an array before dumping to new locations also saves big on time.
Hopes this helps.
I have created a macro to export my sheet as a PDF however some users in the company use Mac OS. When these users attempt to save, it gives them an error. How do I allow both Win and Mac users to use the same PDF export?
Here is my current code:
Sub CreatePDF()
Dim wksSheet As Worksheet
Set wksSheet = ActiveSheet
wksSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\" & Range("exportName"), Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
End Sub
VBA has Application.PathSeparator as well.
http://msdn.microsoft.com/en-us/library/office/ff820973%28v=office.15%29.aspx
I was unable to find the answer to this on SO, but came across this workaround to share:
Sub CreatePDF()
Dim wksSheet As Worksheet
Dim TheOS As String
TheOS = Application.OperatingSystem
If InStr(1, TheOS, "Windows") > 0 Then
Set wksSheet = ActiveSheet
wksSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\" & Range("exportName"), Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
Exit Sub
Else
Set wksSheet = ActiveSheet
wksSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & ":" & Range("exportName"), Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
Exit Sub
End If
End Sub
I'm new to writing Macros and would love some help improving the speed on this one.
I have a sheet with 35,000+ rows, and I'm looping through it to find each instance of a value (OldSKU), grabbing the SKUSubset data associated with it (which has a variable number of rows), and pasting it into a new sheet (SubsetImporter) at the first empty row.
Right now, it can take 5 minutes to loop through and find all the instances of a SKU that shows up multiple times.
OldSKU will only ever show up in Column B. Is there a way to improve the speed of this loop? Possibly defining the range that it should search through?
Sub UpdateSKU()
Dim OldSKU As Long
Dim NewSKU As Long
Dim SKUSubset As String
Dim SubsetRange As Range
Dim aPlace As Range
Dim bPlace As Range
Dim SubsetPastePlace As Long
OldSKU = Sheets("Rollover Request").Range("A2")
NewSKU = Sheets("Rollover Request").Range("B2")
'UPDATE SUBSET IMPORTER
Sheets("Subset Exporter").Activate
Set aPlace = Cells.Find(What:=OldSKU, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
SKUSubset = Cells.Find(What:=OldSKU, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Offset(0, -1).Value
Set bPlace = aPlace
Set aPlace = Cells.Find(What:=OldSKU, After:=aPlace, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
Range("A1", Cells(1, 1).SpecialCells(xlLastCell)).AutoFilter Field:=1, Criteria1:=SKUSubset
Range(ActiveSheet.UsedRange.SpecialCells(xlLastCell), Cells(2, 1)).Copy
SubsetPastePlace = Sheets("Subset Importer").Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
Sheets("Subset Importer").Range("A" & SubsetPastePlace).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Sheets("Subset Exporter").Activate
Sheets("Subset Exporter").Range("A2").Select
Sheets("Subset Exporter").ShowAllData
If bPlace.Row < aPlace.Row Then
Do
SKUSubset = aPlace.Offset(0, -1).Value
Range("A1", Cells(1, 1).SpecialCells(xlLastCell)).AutoFilter Field:=1, Criteria1:=SKUSubset
Range(ActiveSheet.UsedRange.SpecialCells(xlLastCell), Cells(2, 1)).Copy
SubsetPastePlace = Sheets("Subset Importer").Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
Sheets("Subset Importer").Range("A" & SubsetPastePlace).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Sheets("Subset Exporter").Activate
Worksheets("Subset Exporter").ShowAllData
Set bPlace = aPlace
Set aPlace = Cells.Find(OldSKU, After:=aPlace, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
Loop Until aPlace.Row < bPlace.Row
End If
End Sub
Lightly-tested:
Sub UpdateSKU()
Dim OldSKU As Long
Dim NewSKU As Long
Dim SKUSubset As String
Dim SubsetRange As Range
Dim skuCells As Collection, shtExp As Worksheet, shtImp As Worksheet
Dim skuCell
Set shtExp = Sheets("Subset Exporter")
Set shtImp = Sheets("Subset Importer")
OldSKU = Sheets("Rollover Request").Range("A2")
NewSKU = Sheets("Rollover Request").Range("B2")
Set skuCells = FindAll(shtExp.Columns(2), OldSKU) 'get all instances of SKU
shtExp.Activate
For Each skuCell In skuCells
SKUSubset = skuCell.Offset(0, -1).Value
shtExp.Range("A1", Cells(1, 1).SpecialCells(xlLastCell)).AutoFilter _
Field:=1, Criteria1:=SKUSubset
shtExp.Range(shtExp.Cells(2, 1), shtExp.UsedRange. _
SpecialCells(xlLastCell)).Copy
shtImp.Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False
shtExp.ShowAllData
Next skuCell
End Sub
'return a Collection containing all cells with value [findWhat]
Function FindAll(rngToSearch As Range, findWhat As Long) As Collection
Dim rv As New Collection, f As Range, add1 As String
Set f = rngToSearch.Find(what:=findWhat, LookIn:=xlValues, Lookat:=xlWhole)
If Not f Is Nothing Then
add1 = f.Address()
Do While Not f Is Nothing
rv.Add f
Set f = rngToSearch.FindNext(after:=f)
If f.Address = add1 Then Exit Do
Loop
End If
Set FindAll = rv
End Function