In excel I have a macro that converts all of columns of an active sheet into an new sheet called "MasterList"
My problem is when I rerun that macro I get an error saying "That name is already taken." Try a different one.
I need my macro to overwrite MaterList sheet if it already exists.
Here is my code:
Sub ToArrayAndBack()
Dim arr As Variant, lLoop1 As Long, lLoop2 As Long
Dim arr2 As Variant, lIndex As Long
'turn off updates to speed up code execution
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
ReDim arr2(ActiveSheet.UsedRange.Cells.Count - ActiveSheet.UsedRange.SpecialCells(xlCellTypeBlanks).Count)
arr = ActiveSheet.UsedRange.Value
For lLoop1 = LBound(arr, 1) To UBound(arr, 1)
For lLoop2 = LBound(arr, 2) To UBound(arr, 2)
If Len(Trim(arr(lLoop1, lLoop2))) > 0 Then
arr2(lIndex) = arr(lLoop1, lLoop2)
lIndex = lIndex + 1
End If
Next
Next
Sheets.Add.Name = "MasterList"
Range("A1").Resize(, lIndex + 1).Value = arr2
Range("A1").Resize(, lIndex + 1).Copy
Range("A2").Resize(lIndex + 1).PasteSpecial Transpose:=True
Rows(1).Delete
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
End Sub
You can put the sheet creation between on error resume and on error goto 0. The other solution is to loop through the workbook sheets collection and check if a sheet with that name exists.
Solution 1:
On Error Resume Next
Sheets.Add.Name = "MasterList"
On Error GoTo 0
Solution 2:
Dim ws As Worksheet
Dim found As Boolean
found = False
For Each ws In ThisWorkbook.Sheets
If ws.Name = "MasterList" Then
found = True
Exit For
EndIf
Next
If Not found Then
Sheets.Add.Name = "MasterList"
EndIf
To avoid relying on the fact that MasterList is active:
Set ws = ThisWorkbook.Sheets("MasterList")
With ws
.Range("A1").Resize(, lIndex + 1).Value = arr2
.Range("A1").Resize(, lIndex + 1).Copy
.Range("A2").Resize(lIndex + 1).PasteSpecial Transpose:=True
.Rows(1).Delete
End With
Related
I have a 176 worksheets in a workbook, that all have the same format/structure, but are a difference size in row length.
I want to copy the data that is held in range A10:V(X) where X is a calculable number. This data will be pasted underneath each other, in columns B:W of the main sheet "RDBMergeSheet" and the name of the sheet that each row came from will be pasted into Column A of RDBMergeSheet so it can be seen which rows came from which sheets
X = (The lowest used row number in column J) - 3
If it makes it easier, another way to calculate X is find the row number in column A that contains the word "total" and subtract 1 from it.
The following link contains an example of such a sheet, with sanitised data.
https://imgur.com/a/emlZj
The code I've got so far, with help, is:
Sub ImportData()
Dim x As Long
Dim LR As Long
Dim wks As Worksheet
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
Set wks = Sheets("RDBMergeSheet"): If Not wks Is Nothing Then wks.Delete
Set wks = Worksheets.Add(after:=Worksheets(Sheets.Count))
wks.Name = "RDBMergeSheet"
For x = 1 To Worksheets.Count - 1
LR = Application.Max(1, Sheets(x).Cells(Rows.Count, 10).End(xlUp).Row - 3)
With wks.Cells(Rows.Count, 1)
.Offset(1, 1).Resize(LR, 22).Value = .Cells(1, 10).Resize(LR, 22).Value
.Offset(1).Resize(LR - 9).Value = Sheets(x).Name
End With
Next x
wks.Select
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
Set wks = Nothing
End Sub
This errors out with a 1004: Application defined or object defined error on line
.Offset(1, 1).Resize(LR, 22).Value = .Cells(1, 10).Resize(LR, 22).Value
If anyone has any ideas on either how to resolve this I would be extremely grateful.
Please give this a try and tweak it as per your requirement to make sure the correct data is copied starting from the correct row on destination sheet.
Sub ImportData()
Dim LR As Long, dLR As Long, i As Long
Dim wks As Worksheet
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
On Error Resume Next
Set wks = Sheets("RDBMergeSheet")
wks.Cells.Clear
On Error GoTo 0
If wks Is Nothing Then
Set wks = Worksheets.Add(after:=Worksheets(Sheets.Count))
wks.Name = "RDBMergeSheet"
End If
For i = 1 To Worksheets.Count - 1
If Worksheets(i).Name <> wks.Name Then
LR = Application.Max(1, Sheets(i).Cells(Rows.Count, 10).End(xlUp).Row - 3)
If LR > 9 Then
If wks.Range("B1").Value = "" Then
dLR = 1
Else
dLR = wks.UsedRange.Rows.Count + 1
End If
wks.Range("B" & dLR & ":X" & LR - 9).Value = Worksheets(i).Range("B10:X" & LR).Value
wks.Range("A" & dLR).Value = Worksheets(i).Name
End If
End If
Next i
On Error Resume Next
wks.Select
dLR = wks.UsedRange.Rows.Count
wks.Range("A1:A" & dLR).SpecialCells(xlCellTypeBlanks).Formula = "=R[-1]C"
wks.Range("A1:A" & dLR).Value = wks.Range("A1:A" & dLR).Value
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
Set wks = Nothing
End Sub
I'm using below code in vba but it taking too much time to run. Report have 8 sheets and 450+ rows should be check in each sheet.
Sub forloop()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
lr = Cells(Rows.Count, 3).End(xlUp).Row - 1
For s = 1 To Sheets.Count
For x = lr To 1 Step -1
If Cells(x, 2) <> "" Then
Cells(x, 2).EntireRow.Delete
Next x
Next s
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Could you please suggest me any alternate method to run fast.
dim wb as workbook, sht as worksheet, lr as long, r as long
set wb = workbook.open(wbPathHere)
for each sht in wb.worksheets
lr = sht.cells(sht.rows.count, 3).End(xlUp).row - 1
for r = lr to 1 step-1
if sht.cells(r, 2) <> "" Then sht.cells(r, 2).entirerow.delete
next r
next sht
This code works on one sheet and now am trying get it to work across multiple sheets, avoiding the first two sheets ("AA" and "Word Frequency").
Original code here (See #Jeeped's answer)
Link to Worksheet here
Was trying to adapt code from related threads I found (Reference 1, 2) however I do not know how (and whether) to apply the Ws.Name and Ws.Range objects into my existing code.
It seems like the code activates Sheet1 using With Worksheets("Sheet1") and I was trying to replace this with the following method:
Create For looped function byGroupCounter() to identify how many worksheets there are, and run across all existing worksheets. Each worksheet will be incremented with variable "i"
For loop in byGroupCounter() calls on function byGroup(i) to run the original code on the selected worksheet (ie. worksheet "i")
The byGroup() function runs it's process across worksheet i.
Part where I believe I'm getting an error: Replacing the With Worksheets("Sheet1") code to With Ws, where Ws = Worksheets(Sheet_Index) and Sheet_Index is equal to i, defined from byGroupCounter()
I believe I have to add the Ws prefix in front of .Range but everything I've been trying, I keep getting the error "Can't execute code in break mode".
Current Code:
Sub byGroupCounter()
Dim i As Integer
Application.ScreenUpdating = False
For i = ActiveSheet.Index To Sheets.Count
byGroup i
Next i
Application.ScreenUpdating = True
End Sub
Sub byGroup(ByVal Sheets_Index As Integer)
Dim g As Long, s As Long, aSTRs As Variant, aGRPs As Variant
Dim Ws As Worksheet
Set Ws = Worksheets(Sheet_Index)
appTGGL bTGGL:=False
' I believe the next line is where I am doing something wrong:
With Ws
aSTRs = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)).Value2
With .Range(.Cells(1, 5), .Cells(Rows.Count, 1).End(xlUp).Offset(0, Application.Match("zzz", .Rows(1)) - 1))
.Resize(.Rows.Count, .Columns.Count).Offset(1, 0).ClearContents
aGRPs = Ws.Cells.Value2
End With
For s = LBound(aSTRs, 1) To UBound(aSTRs, 1)
For g = LBound(aGRPs, 2) To UBound(aGRPs, 2)
If CBool(InStr(1, aSTRs(s, 1), aGRPs(1, g), vbTextCompare)) Then
aGRPs(s + 1, g) = aSTRs(s, 1)
Exit For
End If
Next g
Next s
.Cells(1, 5).Resize(UBound(aGRPs, 1), UBound(aGRPs, 2)) = aGRPs
End With
appTGGL
End Sub
Public Sub appTGGL(Optional bTGGL As Boolean = True)
Debug.Print Timer
Application.ScreenUpdating = bTGGL
Application.EnableEvents = bTGGL
Application.DisplayAlerts = bTGGL
Application.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
End Sub
There are just 6 changes to the original code to loop through the sheets
I have them commented with '<<<
Sub byGroup()
Dim g As Long, s As Long, aSTRs As Variant, aGRPs As Variant, sh As Worksheet '<<<
appTGGL bTGGL:=False
For Each sh In Sheets '<<<
If sh.Name <> "AA" And sh.Name <> "Word Frequency" Then '<<<<
With sh '<<<
aSTRs = .Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp)).Value2
With .Range(.Cells(1, 5), .Cells(Rows.Count, 1).End(xlUp).Offset(0, Application.Match("zzz", .Rows(1)) - 1))
.Resize(.Rows.Count, .Columns.Count).Offset(1, 0).ClearContents
aGRPs = .Cells.Value2
End With
For s = LBound(aSTRs, 1) To UBound(aSTRs, 1)
For g = LBound(aGRPs, 2) To UBound(aGRPs, 2)
If CBool(InStr(1, aSTRs(s, 1), aGRPs(1, g), vbTextCompare)) Then
aGRPs(s + 1, g) = aSTRs(s, 1)
Exit For
End If
Next g
Next s
.Cells(1, 5).Resize(UBound(aGRPs, 1), UBound(aGRPs, 2)) = aGRPs
End With
End If '<<<<
Next sh '<<<
appTGGL
End Sub
Public Sub appTGGL(Optional bTGGL As Boolean = True)
Debug.Print Timer
Application.ScreenUpdating = bTGGL
Application.EnableEvents = bTGGL
Application.DisplayAlerts = bTGGL
Application.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
End Sub
The code (below) combines all the columns from an active sheet converts them to one Column in a sheet named Sheet3(Masterlist).
I need the to start at row 2 when all the columns are combined. This is because row 1 has the column name.
Also, I would rather use Sheet1(Orders) not the Active Sheet.
This code is modified as suggested by Yaegz. I am now getting Next without For on Line 26:
Sub ToArrayAndBack()
Dim arr As Variant, lLoop1 As Long, lLoop2 As Long
Dim arr2 As Variant, lIndex As Long
'turn off updates to speed up code execution
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
ReDim arr2(Sheet1.UsedRange.Cells.Count - Sheet1.UsedRange.SpecialCells(xlCellTypeBlanks).Count)
arr = Sheet1.UsedRange.Value
Set myRange = Worksheets("Orders").Range("A1:A" & _
Worksheets("Orders").Cells(Worksheets("Orders").Rows.Count, 1).End(xlUp).Row)
i = 2
Do While i <= myRange.Rows.Count
For lLoop1 = LBound(arr, 1) To UBound(arr, 1)
For lLoop2 = LBound(arr, 2) To UBound(arr, 2)
If Len(Trim(arr(lLoop1, lLoop2))) > 0 Then
arr2(lIndex) = arr(lLoop1, lLoop2)
lIndex = lIndex + 1
End If
Next
Next
i = i + i
Loop
Dim ws As Worksheet
Dim found As Boolean
found = False
For Each ws In ThisWorkbook.Sheets
If ws.Name = "MasterList" Then
found = True
Exit For
End If
Next
If Not found Then
Sheets.Add.Name = "MasterList"
End If
Set ws = ThisWorkbook.Sheets("MasterList")
With ws
.Range("A1").Resize(, lIndex + 1).Value = arr2
.Range("A1").Resize(, lIndex + 1).Copy
.Range("A2").Resize(lIndex + 1).PasteSpecial Transpose:=True
.Rows(1).Delete
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
End Sub
Sheet1 is the sheet code. Orders is the sheet name.
If you want to point to a specific sheet instead of the active one use:
Application.Worksheets("name of your sheet") instead of ActiveSheet
The error message is because the do while opens a loop and it closes with the loop key word something like:
Do while i<10
Your Code
i=i+1
Loop
Assuming your code works, if you want a correct Do While loop then use the following code. It sounds like you are trying to just initialize where your code should start. If that is the case then a Do While loop is not the way to go.
arr = ActiveSheet.UsedRange.Value
Set myRange = Worksheets("Sheet1").Range("A1:A" & _
Worksheets("Sheet1").Cells(Worksheets("Sheet1").Rows.Count, 1).End(xlUp).Row)
i = 2
Do While i <= myRange.Rows.Count
For lLoop1 = LBound(arr, 1) To UBound(arr, 1)
For lLoop2 = LBound(arr, 2) To UBound(arr, 2)
If Len(Trim(arr(lLoop1, lLoop2))) > 0 Then
arr2(lIndex) = arr(lLoop1, lLoop2)
lIndex = lIndex + 1
End If
Next
Next
i = i + i
Loop
I have some code that runs fine in Excel 2007 but when used in Excel 2010 takes about ten times longer to run and causes the whole taskbar/other programs to be unresponsive.
I don't believe hardware is the problem because the computer running Excel 2007 is a Pentium 4 with 2 gigs of ram, while the computer running 2010 is an i7 with 8 gigs of ram.
Here is the code itself:
Sub Macro6()
With Application
.ScreenUpdating = False 'Prevent screen flickering
.Calculation = xlCalculationManual 'Preventing calculation
.DisplayAlerts = False 'Turn OFF alerts
.EnableEvents = False 'Prevent All Events
End With
Dim i As Integer
Dim j As Integer
Dim Anc As String
Dim MSA As String
j = 1
Do
i = 0
MSA = ActiveCell
Selection.Copy
Sheets("Sheet1").Select
ActiveCell.Offset(0, -2).Select
ActiveSheet.Paste
ActiveCell.Offset(0, 2).Select
Sheets("wip").Select
Do
i = i + 1
ActiveCell.Offset(0, 1).Select
Anc = ActiveCell.Offset(-j, 0)
Selection.Copy
Sheets("Sheet1").Select
ActiveCell.Offset(0, -1) = Anc
ActiveCell.Offset(0, -2) = MSA
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Select
Sheets("wip").Select
Loop Until IsEmpty(ActiveCell.Offset(0, 1))
j = j + 1
ActiveCell.Offset(1, -i).Select
Loop Until IsEmpty(ActiveCell)
'Speeding Up VBA Code
With Application
.ScreenUpdating = True 'Prevent screen flickering
.Calculation = xlAutomatic 'Preventing calculation
.DisplayAlerts = True 'Turn OFF alerts
.EnableEvents = True 'Prevent All Events
End With
End Sub
The code does what I want it to, but I am concerned as to why in 2010 there is such a difference in running time?
Is this what you are trying to do?
Option Explicit
Sub Sample()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim i As Long, j As Long, k As Long, lRow As Long, lCol As Long
On Error GoTo Whoa
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
'~~> Setting the worksheets to work with
Set ws1 = Sheets("wip"): Set ws2 = Sheets("Sheet1")
'~~> Setting the start cell in "Sheet1"
k = 3
With ws1
'~~> Get the last row in Col A of "wip"
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Get the last column in row 3 of "wip"
lCol = .Cells(3, .Columns.Count).End(xlToLeft).Column
'~~> Looping through rows in Col A in "wip"
For i = 3 To lRow
'~~> Looping through columns in the relevant row in "wip"
For j = 3 To lCol + 1
'~~> Writing output directly in "Sheet1"
ws2.Cells(k, 1).Value = ws1.Cells(i, 1).Value
ws2.Cells(k, 3).Value = ws1.Cells(i, 1).Offset(, j - 2).Value
k = k + 1
Next j
Next i
End With
LetsContinue:
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub