Can you you help to combine this 2 code and remove all unnecessary lines to avoid long running time, and I tried to combine it but I get Run time error #9
STEP 1 (Code# 1)
Sub STEP1()
Dim ws As Worksheet
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
With ws.Range("B:B")
.NumberFormat = "General"
.Value = .Value
.HorizontalAlignment = xlLeft
End With
Debug.Print ws.Name
Next ws
Application.ScreenUpdating = True
End Sub
STEP 2 (Code# 2)
Sub STEP_2()
Dim ws As Worksheet
For Each ws In Sheets
ws.Cells(1, 1).EntireColumn.Delete
Next ws
Sheets("x_ 659358").Select
Rows("2:3").Select
Selection.Delete Shift:=xlUp
Sheets("x_682549 (2)").Select
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
Dim headers() As Variant
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
headers() = Array("sku", "barcode", "active", "price")
For Each ws In wb.Sheets
With ws
.Rows(1).Value = ""
For i = LBound(headers()) To UBound(headers())
.Cells(1, 1 + i).Value = headers(i)
Next i
.Rows(1).Font.Bold = True
End With
Next ws
Dim xWs As Worksheet
Dim xDir As String
Dim folder As FileDialog
Set folder = Application.FileDialog(msoFileDialogFolderPicker)
If folder.Show <> -1 Then Exit Sub
xDir = folder.SelectedItems(1)
For Each xWs In Application.ActiveWorkbook.Worksheets
xWs.SaveAs xDir & "\" & xWs.Name, xlCSV
Next
End Sub
I have tried to combine but always get stucked
Sub STEP1()
' your code...
Call STEP_2() ' <----
End Sub
Sub STEP_2()
' your code...
End Sub
Related
I'm new in Excel-VBA and I need to improve my macro performance. I have a macro that searches an excel, opens it, then goes through every sheet and copy-pastevalues for all cell with a specific color (yellow). Finally saves and closes the excel. In addition, excels sheets are locked and only those yellow cells are editable. This should be done for a list of excel that I indicate in a main template from where I call the macro. The problem is that it takes a lot of time and even gets blocked when the number of excels is more than 3.
I paste my code below and hope anyone can help. Thanks!
Sub Button1_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim filePath As String
Dim rng As Range
Dim cel As Range
Dim cartera As String
Dim plantilla As String
Dim wb As Workbook
Dim ws As Worksheet
Dim obj_Cell As Range
filePath = Application.ThisWorkbook.Path
Range("B9").Select
Set rng = Application.Range(Selection, Selection.End(xlDown))
For Each cel In rng.Cells
cartera = cel.Value
plantilla = cel.Offset(0, 1).Value
If cartera = vbNullString Or plantilla = vbNullString Then
GoTo Saltar
End If
Application.StatusBar = "Ejecutando Cartera: " & cartera & ", Plantilla: " & plantilla
Set wb = Workbooks.Open(filePath & "\" & cartera & "\" & plantilla, UpdateLinks:=3)
For Each ws In wb.Worksheets
If ws.Name <> "Index" And ws.Name <> "Instructions" And ws.Name <> "Glossary" Then
Worksheets(ws.Name).Activate
For Each obj_Cell In Range("A1:DW105")
With obj_Cell
If obj_Cell.Interior.Color = RGB(255, 255, 153) Then
obj_Cell.Select
If obj_Cell.MergeCells = True Then
obj_Cell.MergeArea.Select
End If
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
If obj_Cell.MergeCells = True Then
If obj_Cell.MergeArea(1).Value = vbNullString Then
obj_Cell.MergeArea.Cells(1, 1).Select
Selection.ClearContents
End If
Else
If obj_Cell.Value = vbNullString Then
obj_Cell.ClearContents
End If
End If
End If
End With
Next obj_Cell
Range("A1").Select
End If
Next ws
Sheets(1).Select
wb.Close SaveChanges:=True
Saltar:
Next cel
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.StatusBar = False
End Sub
Untested- just some "start" ideas for you to use (e.g. no selections, using arrays, fix With statement, no GoTo). I don't understand the logic behind clearing vbNullstring. If it is necessary adapt the code in your way.
I would also suggest opening files with displayalerts on because of few potential problems (e.g. "serious error occur last time file was opened" would hangs your macro)
Sub Button1_Click()
With Application
.ScreenUpdating = False
.StatusBar = True
End With
' If possible change this reference
' from active sheet to sheet's name/codename/index
Dim activeWs As Worksheet
Set activeWs = ActiveSheet
Dim filePath As String
filePath = Application.ThisWorkbook.Path
Dim wb As Workbook
Dim ws As Worksheet
Dim obj_Cell As Range
' range definition
' if lastRow not working change to yours xlDown
' if possible End(xlUp) method is more reliable
Dim rng As Range
Dim lastRw As Long
With activeWs
lastRw = .Cells(.Cells.Rows.Count, "B").End(xlUp).Row
Set rng = .Range("B9:B" & lastRw)
End With
' read whole ranges at once
' instead of offset it is possible also to read
' cartera and plantilla at the same time to 2Darray
Dim cartera As Variant
cartera = Application.Transpose(rng.Value2)
Dim plantilla As Variant
plantilla = Application.Transpose(rng.Offset(, 1).Value2)
' main loop
Dim i As Long
For i = 1 To UBound(cartera)
If cartera(i) <> vbNullString Or plantilla(i) <> vbNullString Then
Application.StatusBar = "Ejecutando Cartera: " & cartera(i) & ", Plantilla: " & plantilla(i)
Set wb = Workbooks.Open(filePath & "\" & cartera(i) & "\" & plantilla(i), UpdateLinks:=3)
For Each ws In wb.Worksheets
If ws.Name <> "Index" And ws.Name <> "Instructions" And ws.Name <> "Glossary" Then
For Each obj_Cell In ws.Range("A1:DW105")
With obj_Cell
If .Interior.Color = RGB(255, 255, 153) Then
.Value2 = .Value2
' I commented this part beacuse it does not make sense for me...
' If .MergeCells Then
' If .MergeArea(1).Value = vbNullString Then _
.MergeArea.Cells(1, 1).ClearContents
' Else
' If .Value = vbNullString Then .ClearContents
' End If
End If
End With
Next obj_Cell
End If
Next ws
' I would place diplayalerts off here because of potential problems
' with opening files
' if problem occurs it can macro hangs
Application.DisplayAlerts = False
wb.Close SaveChanges:=True
Application.DisplayAlerts = True
End If
Next i
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.StatusBar = False
End With
End Sub
I tried using .xlsb file so as to execute it in all different workbooks, but keep getting Error 400, even though my Macro is working for that particular file. I wrote this simple code to delete the empty rows and columns in the workbook.
Sub RepeatTask()
Dim xSh As Worksheet
Application.ScreenUpdating = False
For Each xSh In Worksheets
xSh.Select
Call task
Next
Application.ScreenUpdating = True
End Sub
Sub task()
Dim LastColumnIndex As Integer
Dim LastRowIndex As Integer
Dim RowIndex As Integer
Dim ColumnIndex As Integer
Dim UsedRng As Range
Set UsedRng = ActiveSheet.UsedRange
LastRowIndex = UsedRng.Row - 1 + UsedRng.Rows.Count
LastColumnIndex = UsedRng.Column - 1 + UsedRng.Columns.Count
Application.ScreenUpdating = False
For RowIndex = LastRowIndex To 1 Step -1
If Application.CountA(Rows(RowIndex)) = 0 Then
Rows(RowIndex).Delete
End If
Next RowIndex
For ColumnIndex = LastColumnIndex To 1 Step -1
If Application.CountA(Columns(ColumnIndex)) = 0 Then
Columns(ColumnIndex).Delete
End If
Next ColumnIndex
Application.ScreenUpdating = True
End Sub
I recommend not to use .Select instead give the worksheet as parameter and specify the sheet in all ws.Rows(), ws.Columns() etc.
If you make the parameter Optional you can fallback to If ws Is Nothing Then Set ws = ActiveSheet if Task is called without parameter.
Sub RepeatTask()
Dim xSh As Worksheet
Application.ScreenUpdating = False
For Each xSh In Worksheets
Task xSh 'give worksheet as parameter here instead of select!
Next
Application.ScreenUpdating = True
End Sub
Sub Task(Optional ws As Worksheet)
If ws Is Nothing Then Set ws = ActiveSheet
Dim LastColumnIndex As Long
Dim LastRowIndex As Long
Dim RowIndex As Long
Dim ColumnIndex As Long
Dim UsedRng As Range
Set UsedRng = ws.UsedRange
LastRowIndex = UsedRng.Row - 1 + UsedRng.Rows.Count
LastColumnIndex = UsedRng.Column - 1 + UsedRng.Columns.Count
Application.ScreenUpdating = False
For RowIndex = LastRowIndex To 1 Step -1
If Application.CountA(ws.Rows(RowIndex)) = 0 Then
ws.Rows(RowIndex).Delete
End If
Next RowIndex
For ColumnIndex = LastColumnIndex To 1 Step -1
If Application.CountA(ws.Columns(ColumnIndex)) = 0 Then
ws.Columns(ColumnIndex).Delete
End If
Next ColumnIndex
Application.ScreenUpdating = True
End Sub
The way I could do this for multiple Excel workbooks is here:
Sub OpenFiles()
Dim xStrPath As String
Dim xFileDialog As FileDialog
Dim xFile As String
On Error Resume Next
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
xFileDialog.AllowMultiSelect = False
xFileDialog.Title = "Select a folder [Kutools for Excel]"
If xFileDialog.Show = -1 Then
xStrPath = xFileDialog.SelectedItems(1)
End If
If xStrPath = "" Then Exit Sub
xFile = Dir(xStrPath & "\*.xlsm")
Do While xFile <> ""
Workbooks.Open xStrPath & "\" & xFile
xFile = Dir
Loop
Call Optil
Call SaveAndCloseAllWorkbooks
End Sub
Sub Optil()
Dim book As Workbook, sheet As Worksheet
Application.ScreenUpdating = False
For Each book In Workbooks
For Each sheet In book.Worksheets
Task sheet
Next sheet
Next book
Application.ScreenUpdating = True
End Sub
Sub RepeatTask()
Dim xSh As Worksheet
Application.ScreenUpdating = False
For Each xSh In Worksheets
Task xSh 'give worksheet as parameter here instead of select!
Next
Application.ScreenUpdating = True
End Sub
Sub Task(Optional ws As Worksheet)
If ws Is Nothing Then Set ws = ActiveSheet
Dim LastColumnIndex As Long
Dim LastRowIndex As Long
Dim RowIndex As Long
Dim ColumnIndex As Long
Dim UsedRng As Range
Set UsedRng = ws.UsedRange
LastRowIndex = UsedRng.Row - 1 + UsedRng.Rows.Count
LastColumnIndex = UsedRng.Column - 1 + UsedRng.Columns.Count
Application.ScreenUpdating = False
For RowIndex = LastRowIndex To 1 Step -1
If Application.CountA(ws.Rows(RowIndex)) = 0 Then
ws.Rows(RowIndex).Delete
End If
Next RowIndex
For ColumnIndex = LastColumnIndex To 1 Step -1
If Application.CountA(ws.Columns(ColumnIndex)) = 0 Then
ws.Columns(ColumnIndex).Delete
End If
Next ColumnIndex
Application.ScreenUpdating = True
End Sub
Sub SaveAndCloseAllWorkbooks()
Dim bk As Workbook
For Each bk In Workbooks
If Not bk Is ThisWorkbook Then
bk.Close SaveChanges:=True
End If
Next bk
'If You want to save and close active workbook too
'ThisWorkbook.Close SaveChanges:=True
End Sub
I used vba to create a TOC for my workbook, but the code formatted my wsname to a number format and removed the leading zeros. Is there a way to modify the code to include the leading zeros in the links?
For example, each of my worksheets is titled with a number beginning with a zero such as "0303855" etc. When I ran this code, my TOC list was numbers without the zero ("303855" etc).
I used the following code:
Sub CreateTOC()
Dim wsA As Worksheet
Dim ws As Worksheet
Dim wsTOC As Worksheet
Dim lRow As Long
Dim rngList As Range
Dim lCalc As Long
Dim strTOC As String
Dim strCell As String
lCalc = Application.Calculation
On Error GoTo errHandler
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
strTOC = "TOC"
strCell = "A1"
Set wsA = ActiveSheet
On Error Resume Next
Set wsTOC = Sheets(strTOC)
On Error GoTo errHandler
If wsTOC Is Nothing Then
Set wsTOC = Sheets.Add(Before:=Sheets(1))
wsTOC.Name = strTOC
Else
wsTOC.Cells.Clear
End If
With wsTOC
.Range("B1").Value = "Sheet Name"
lRow = 2
For Each ws In ActiveWorkbook.Worksheets
If ws.Visible = xlSheetVisible _
And ws.Name <> strTOC Then
.Cells(lRow, 2).Value = ws.Name
.Hyperlinks.Add _
Anchor:=.Cells(lRow, 2), _
Address:="", _
SubAddress:="'" & ws.Name _
& "'!" & strCell, _
ScreenTip:=ws.Name, _
TextToDisplay:=ws.Name
lRow = lRow + 1
End If
Next ws
Set rngList = .Cells(1, 2).CurrentRegion
rngList.EntireColumn.AutoFit
.Rows(1).Font.Bold = True
End With
Application.ScreenUpdating = True
wsTOC.Activate
wsTOC.Cells(1, 2).Activate
exitHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = lCalc
Set rngList = Nothing
Set wsTOC = Nothing
Set ws = Nothing
Set wsA = Nothing
Exit Sub
errHandler:
MsgBox "Could not create list"
Resume exitHandler
End Sub
There is runtime error 91 on for loop need help!!
Sub clearSheet(WSName As String)
Dim ws As Worksheet
Set ws = Nothing
With ActiveWorkbook
Dim blWSExists As Boolean
blWSExists = False
For i = 1 To .Sheets.Count
If .Sheets(i).Name = WSName Then
blWSExists = True
.Sheets(i).Activate
.Sheets(i).Visible = xlSheetVisible
End If
Next
If Not blWSExists Then
Set ws = .Sheets.Add
ws.Move after:=.Sheets(.Sheets.Count)
ws.Name = WSName
ws.Visible = xlSheetVisible
End If
.Sheets(WSName).AutoFilterMode = False
.Sheets(WSName).Cells.Clear
.Sheets(WSName).UsedRange.ClearOutline
.Sheets(WSName).Cells.ClearFormats
End With
End Sub
Try that:
Dim ws As Worksheet
Dim blWSExists As Boolean
blWSExists = False
For Each ws In Worksheets
If ws.Name = WSName Then
blWSExists = True
End If
Next
If Not blWSExists Then
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = WSName
End If
Set ws = ActiveWorkbook.Sheets(WSName)
ws.AutoFilterMode = False
ws.Cells.Clear
ws.UsedRange.ClearOutline
ws.Cells.ClearFormats
ws.Activate
You can use Cells.Delete() to clear everything on a Worksheet:
Sub clearSheet(WSName As String)
Dim s As Object
For Each s in ThisWorkbook.Sheets
If s.Name = WSName Then
s.Visible = xlSheetVisible
If TypeOf s Is worksheet Then s.Cells.Delete ' not all Sheets have cells, but all Worksheets do
Exit Sub ' to ignore the rest of the code if the Sheet exists
End If
Next
ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = WSName
End Sub
or just delete the sheet and add new to clear absolutely everything associated with the sheet:
Sub clearSheet(WSName As String)
On Error Resume Next
Sheets(WSName).Delete
Sheets.Add(After:=Sheets(Sheets.Count)).Name = WSName
End Sub
I'm trying to loop through sheets, and remove row entries that are not equal to sheet name.
I've if statements to ignore particular sheets.
It will only work on one sheet and won't loop through all.
Sub CleanRegionalSheets()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim lngx As Long
With ws
For Each ws In ActiveWorkbook.Worksheets
If ActiveSheet.Name = "Raw Data" Then
ElseIf ActiveSheet.Name = "Building Status" Then
ElseIf ActiveSheet.Name = "Clean Data" Then
Else
For lngx = Cells(Rows.Count, "A").End(xlUp).Row To 3 Step -1
If Cells(lngx, "A").Value <> ActiveSheet.Name Then
Cells(lngx, "A").EntireRow.Delete Shift:=xlUp
End If
Next
End If
Next
End With
End Sub
Updated code, still not working:
Sub CleanRegionalSheets()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim lngx As Long
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "Raw Data" Then
ElseIf ws.Name = "Building Status" Then
ElseIf ws.Name = "Clean Data" Then
Else
For lngx = Cells(Rows.Count, "A").End(xlUp).Row To 3 Step -1
If Cells(lngx, "A").Value <> ws.Name Then
Cells(lngx, "A").EntireRow.Delete Shift:=xlUp
End If
Next
End If
Next
End Sub
You are missing the ws object. Try this (you also forgot to enable ScreenUpdate at the end):
Sub CleanRegionalSheets()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim lngx As Long
For Each ws In ActiveWorkbook.Worksheets
Select Case ws.Name
Case "Raw Data", "Building Status", "Clean Data"
Case Else
With ws
For lngx = .Cells(.Rows.Count, "A").End(xlUp).Row To 3 Step -1
If .Cells(lngx, "A").Value <> .Name Then
.Rows(lngx).Delete Shift:=xlUp
End If
Next
End With
End Select
Next
Application.ScreenUpdating = True
End Sub