The following code returns the name of all the worksheets from the workbook. What I would like it to do is to return only the name of my active sheets.
I have multiple Sheets selected
What do I need to change to correct it? I suppose it's in that "For each" section
Sub test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim x As Integer
x = 0
Dim aSheetnames As Variant
aSheetnames = Array("")
For Each ws In Worksheets
'Redimensiona array
ReDim Preserve aSheetnames(x)
aSheetnames(x) = ws.Name
x = x + 1
Next ws
Dim str As String
For j = LBound(aSheetnames) To UBound(aSheetnames)
str = str & aSheetnames(j) & Chr(13)
Next j
MsgBox str
End Sub
You can use the following code snippet to get all selected sheets.
ActiveWorkbook.Windows(1).SelectedSheets
Description: SelectedSheets
Otherwise you can also get the name of the activated sheet with
ThisWorkbook.ActiveSheet.Name
Description: ActiveSheet
In your case you have to change the For loop as follows:
For Each ws In ActiveWorkbook.Windows(1).SelectedSheets
ReDim Preserve aSheetnames(x)
aSheetnames(x) = ws.Name
x = x + 1
Next ws
Related
How to add a worksheet in excel with VBA after a specific sheetname held by variable?
I tried:
Set sh = wb.Worksheets.Add(After:=wb.Sheets(wsPattern & CStr(n)))
The previous incremented sheetname is stored in "wsPattern & CStr(n)", The new sheetname increments up properly from another statement and variable, but the add after fails with the above syntax. I'm getting an out of range error at this line.
The code fully executes using this statement, but adds any newly created sheets from any given series at the end of all sheets:
Set sh = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
As the workbook has 4 series of sheet names now (e.g. Test1, logistic1, Equip1, Veh1, etc.) that are incremented up as they are added, the next incremented sheet for a given series needs to be added to the end of that sheet name series (Equip2 should be after Equip1) and not at the end of all sheets.
Sub CreaIncWkshtEquip()
Const wsPattern As String = "Equip "
Dim wb As Workbook: Set wb = ThisWorkbook
Dim arr() As Long: ReDim arr(1 To wb.Sheets.Count)
Dim wsLen As Long: wsLen = Len(wsPattern)
Dim sh As Object
Dim cValue As Variant
Dim shName As String
Dim n As Long
For Each sh In wb.Sheets
shName = sh.Name
If StrComp(Left(shName, wsLen), wsPattern, vbTextCompare) = 0 Then
cValue = Right(shName, Len(shName) - wsLen)
If IsNumeric(cValue) Then
n = n + 1
arr(n) = CLng(cValue)
End If
End If
Next sh
If n = 0 Then
n = 1
Else
ReDim Preserve arr(1 To n)
For n = 1 To n
If IsError(Application.Match(n, arr, 0)) Then
Exit For
End If
Next n
End If
'adds to very end of workbook
'Set sh = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
'Test-Add After Last Incremented Sheet-
Set sh = wb.Worksheets.Add(After:=wb.Sheets(wsPattern & CStr(n)))
sh.Name = wsPattern & CStr(n)
End Sub
Create a function
Sub Demo()
Dim s
s = AddSheet("SeriesName")
MsgBox s & " Added"
End Sub
Function AddSheet(sSeries As String) As String
Dim ws, s As String, i As Long, n As Long
With ThisWorkbook
' find last in series
For n = .Sheets.Count To 1 Step -1
s = .Sheets(n).Name
If s Like sSeries & "[1-9]*" Then
i = Mid(s, Len(sSeries) + 1)
Exit For
End If
Next
' not found add to end
If i = 0 Then
n = .Sheets.Count
End If
' increment series
s = sSeries & i + 1
.Sheets.Add after:=.Sheets(n)
.Sheets(n + 1).Name = s
End With
AddSheet = s
End Function
I am trying to add values from a specific range(column) into a listbox. However, the range has blank cells and duplicates that I am trying to get rid of. The following code works (no error msg) and does populate the listbox, but it does not get rid of the duplicates.
Can someone help?
Private Sub UserForm_Initialize()
Dim rang, rang1 As Range
Dim lstrow As Long
Dim list(), ListUniq() As Variant
Dim iRw As Integer
Dim wb As Workbook
Dim ws As Worksheet
Dim x As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("Paramed Verification Grid")
Set rang = ws.Range("E3").CurrentRegion
lstrow = rang.Rows.Count + 1
Set rang1 = Range("E3:E" & lstrow)
'list = ws.Range("E3:E" & lstrow).SpecialCells(xlCellTypeConstants)
'Resize Array prior to loading data
ReDim list(WorksheetFunction.CountA(rang1))
'Loop through each cell in Range and store value in Array
x = 0
For Each cell In rang1
If cell <> "" Then
list(x) = cell.Value
x = x + 1
End If
Next cell
ListUniq = WorksheetFunction.Unique(list)
ListUniq = WorksheetFunction.Sort(ListUniq)
ProviderListBx.list = ListUniq
End Sub
I keep getting
runtime error 1004 - Application defined or object defined error
for the code below. Could you help me figure out why this is happening?
Option Explicit
Sub DeleteSheet()
Dim Sh As Worksheet
Application.DisplayAlerts = False
For Each Sh In ThisWorkbook.Worksheets
If Application.WorksheetFunction.Search("Generation", Sh.Range("A1").Value, 1) = 1 Then
Sh.Delete
End If
Next Sh
Application.DisplayAlerts = True
End Sub
You can't delete a sheet which is also a control variable in a loop. Use a counter instead to iterate through the sheets, then delete using the counter, eg
dim sheetCount
dim i
sheetCount = ThisWorkbook.Worksheets.Count
for i = sheetCount to 1 step -1
dim sh as Worksheet
set sh = ThisWorkbook.Worksheets(i)
If Application.WorksheetFunction.Search("Generation", sh.Range("A1").Value, 1) = 1 Then
ThisWorkbook.Worksheets(i).Delete
End If
next i
Delete Worksheets Using an Array of Worksheet Names
I couldn't reproduce the exact error.
The covered scenarios producing errors were the following:
when generation was not found in cell A1,
the last sheet cannot be deleted,
when a sheet was very hidden.
VBA has its own FIND or SEARCH equivalent called Instr.
In the workbook containing this code (ThisWorkbook), it will delete all worksheets whose cell A1 contains a string starting with Generation.
Option Explicit
Sub DeleteSheets()
Dim wsCount As Long: wsCount = ThisWorkbook.Worksheets.Count
Dim wsNames() As String: ReDim wsNames(1 To wsCount) ' Worksheet Names Array
Dim ws As Worksheet
Dim n As Long
For Each ws In ThisWorkbook.Worksheets
' Check if 'A1' contains a string starting with 'Generation'.
If InStr(1, CStr(ws.Range("A1").Value), "Generation", _
vbTextCompare) = 1 Then
n = n + 1 ' next array element
wsNames(n) = ws.Name ' write the worksheet name to the array
End If
Next ws
' Check if no worksheet name was added to the array.
If n = 0 Then Exit Sub
' Resize the array to the number of found worksheets.
If n < wsCount Then ReDim Preserve wsNames(1 To n)
' Delete the worksheets, without confirmation, in one go.
Application.DisplayAlerts = False
ThisWorkbook.Worksheets(wsNames).Delete
Application.DisplayAlerts = True
End Sub
This section of code should loop through the table of data in the column I tell it to, and if it is not 0 or blank it should copy the whole row of the table to another spreadsheet which is my formatted reports sheet.
This code seems good to me, and I have other similar pieces of code that work fine but this one does not for some reason.
Public Sub getActiveCodes()
Dim tRows
Dim i As Integer
Dim ws As Worksheet, rpts As Worksheet
Dim nxtRow As Integer
Set ws = Worksheets("Sheet1")
Set rpts = Worksheets("REPORTS")
For i = 1 To i = ws.Range("mainTable").Rows.Count
nxtRow = Module1.countRows(rpts)
If ws.ListObjects("mainTable").DataBodyRange(i, 9).Value <> 0_
Or "" Then
ws.ListObjects("mainTable").ListRows(i).Range.Copy
rpts.Range("A:" & nxtRow).PasteSpecial , Paste:=xlPasteValues
End If
Next i
End Sub
I would like this function to make a report of all data pertaining to each row item that is not zero in this column.
Cleaned up the code for you
Public Sub getActiveCodes()
Dim tRows
Dim i As Long, nxtRow As Long
Dim wb As Workbook
Dim ws As Worksheet, rpts As Worksheet
Set wb = Workbooks(REF)
Set ws = wb.Worksheets("Sheet1")
Set rpts = wb.Worksheets("REPORTS")
For i = 1 To ws.Range("mainTable").Rows.Count
nxtRow = Module1.countRows(rpts)
If ws.ListObjects("mainTable").DataBodyRange(i, 9).Value <> 0 _
Or ws.ListObjects("mainTable").DataBodyRange(i, 9).Value <> "" Then
ws.ListObjects("mainTable").ListRows(i).Range.Copy
rpts.Range("A:" & nxtRow).PasteSpecial xlPasteValues
End If
Next i
End Sub
Problem was your underscore and the general If statement. Before a line break, add a space. Moreover you shouldn't do If x = 1 Or 2, you should always include the value you compare it to, so If x = 1 Or x = 2. That is because If x = 1 Or 2 reads as if x = 1 is true or if 2 is true, which will always be true because whether or not x = 1, there is nothing false about the number 2 on its own.
Using the Copy function to just copy values is slow. You're better off equalising the values of two ranges like Range("A1:A20").Value = Range("B2:B21").Value
My brain is fried and this is easy points for the usual suspects. div is an array holding sheet names. I am looping through sheets in a master book and if one of the master sheets match one of the sheets in the div array, I want to transfer some data from master sheet to a sheet in thisworkbook.
In the event the sheet does not exist in thisworkbook, add one and name it after the master sheet. What's the most efficient way to do this? I feel like nested loops is a bad idea -_- A collection perhaps?
For i = 0 To UBound(div())
For Each s In book.Worksheets
wsName = Left(s.Name, 5)
If div(i) = wsName Then
If wsExists(wsName) Then
Set ws = ThisWorkbook.Worksheets(wsName)
Exit For
'Debug.Print "true " & ws.name
Else
Set ws = ThisWorkbook.Worksheets.Add
ws.Name = Left(s.Name, 5)
'Debug.Print "false " & ws.name
End If
end if
Next
With ws
.Columns(Start).Resize(, 2).Value = s.Columns("A:B").Value
.Columns(Start + label).Resize(, cols).Value = s.Columns(Start + label).Resize(, cols).Value
End With
Next
Do I even need to check if sheet exists? Code stolen from Tim.
Function wsExists(sName As String) As Boolean
Dim sht As Worksheet
On Error Resume Next
Set sht = ThisWorkbook.Sheets(sName)
On Error GoTo 0
wsExists = Not sht Is Nothing
End Function
Edit: I am calling the loop from a separate routine.
Call drop(thisWB, thisRange, ccArr)
where ccArr is
Dim ccArr() As Variant
ccArr = Array("30500", "30510", "30515", "30530", "30600", "30900", "40500")
The routine where above loop resides opens with
Sub drop(book As Workbook, cols As Integer, div As Variant, Optional startCol As Integer)
but I am getting a byref error trying to pass the array ;_;
Your nested loop is superfluous. You can check the sheet name from div directly against the workbook you want to check it against, then add it if needed.
See the code below, which also addresses the concerns in the edits to your OP. I modified the wsExists function to include a set reference to a particular workbook, which I think makes it more dynamic.
'assumes thisWB and thisRange set above
Dim ccArr() As String, sList As String
sList = "30500,30510,30515,30530,30600,30900,40500"
ccArr = Split(sList, ",")
drop thisWB, thisRange, ccArr 'assumes thisWb and thisRange are set already
' rest of code
'==================================================
Sub drop(book As Workbook, cols As Integer, div() As String, Optional startCol as Integer)
For i = 0 To UBound(div())
If wsExists(ThisWorkbook, div(i)) Then
Set ws = ThisWorkbook.Worksheets(div(i))
Exit For
'Debug.Print "true " & ws.name
Else
Set ws = ThisWorkbook.Worksheets.Add
ws.Name = div(i)
End If
'i think you need this here, otherwise, it will only work on the last worksheet in your loop
With ws
Dim s As Worksheet
Set s = book.Sheets(div(i))
.Columns(Start).Resize(, 2).Value = s.Columns("A:B").Value
.Columns(Start + Label).Resize(, cols).Value = s.Columns(Start + Label).Resize(, cols).Value
End With
Next
End Sub
Function wsExists(wb As Workbook, sName As String) As Boolean
Dim sht As Worksheet
On Error Resume Next
Set sht = wb.Sheets(sName)
On Error GoTo 0
wsExists = Not sht Is Nothing
End Function
Related to the re-sizing code:
This statement ws.Columns(1).Resize(, 2) translates to "2 million+ rows from column 1 and 2"
The solution you found works well but it's not dynamic (hard-coded last row)
This is how I'd setup the copy of columns:
Option Explicit
Public Sub copyCols()
Dim ws1 As Worksheet, ws2 As Worksheet, rng1 As Range, rng2 As Range
Dim cols As Long, lr As Long
Dim col1 As Long 'renamed from "Start" (VBA keyword - property)
Dim lbl As Long 'renamed from "label" (VBA keyword - Control object)
Set ws1 = Sheet1 'ws
Set ws2 = Sheet2 'book.Worksheets(wsName & "-F")
col1 = 1
cols = 2
lbl = 1
lr = ws2.Cells(ws2.UsedRange.Row + ws2.UsedRange.Rows.Count, "A").End(xlUp).Row
Set rng1 = ws1.Range(ws1.Cells(1, col1), ws1.Cells(lr, col1 + 1))
Set rng2 = ws2.Range("A1:B" & lr)
rng1.Value2 = rng2.Value2
Set rng1 = ws1.Range(ws1.Cells(1, col1 + lbl), ws1.Cells(lr, col1 + lbl + cols))
Set rng2 = ws2.Range(ws2.Cells(1, col1 + lbl), ws2.Cells(lr, col1 + lbl + cols))
rng1.Value2 = rng2.Value2
End Sub