Trying to delete sheets based on data from another workbook sheet - By comparing and accessing data from another workbook sheet, however its not working. I was able to do it if the sheet was in the same workbook, however i do not want to import the worksheet every time.
Code so far, My problem is calling from another workbook sheet.
sub delete()
Dim wb As Workbook
Dim wks As Worksheet
Dim MyRange As Range
Dim Cell As Range
Set wb = Workbooks("name.xlsx")
Set wks = wb.Worksheets("allnames")
With wks
Set MyRange = wks.Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
End With
On Error Resume Next
Application.DisplayAlerts = False
For Each Cell In MyRange
Sheets(Cell.Value).Delete
Next Cell
Application.DisplayAlerts = True
On Error GoTo 0
End Sub
Thanks in advance
maybe you're after something like this:
Option Explicit
Sub delete()
Dim toDeleteSheetsWb As Workbook
Dim Cell As Range
Set toDeleteSheetsWb = Workbooks("WorkbookWithSheetsToDelete.xlsx") '<-- set the workbook whose sheets will be deleted (change "WorkbookWithSheetsToDelete.xlsx" to its actual name)
With Workbooks("name.xlsx").Worksheets("allnames") '<-- reference the worksheet from which to read worksheets names to be deleted in "WorkbookWithSheetsToDelete.xlsx" workbook
Application.DisplayAlerts = False
For Each Cell In .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
toDeleteSheetsWb.Sheets(Cell.Value).delete
Next Cell
Application.DisplayAlerts = True
End With
End Sub
Related
I have set up code to copy a filtered table into a new document, it works fine but for some reason the data ends up in Sheet 2 of the new workbook. Could someone please enlighten me as to why? I cant see any reference to sheet 2 so am very confused (also very much a novice)
Here is the code I use:
Sub CopyFilteredTable()
Dim rng As Range
Dim WS As Worksheet
Set newBook = Workbooks.Add
For Each Row In Range("Table2[#All]").Rows
If Row.EntireRow.Hidden = False Then
If rng Is Nothing Then Set rng = Row
Set rng = Union(Row, rng)
End If
Next Row
Set WS = Sheets.Add
rng.Copy newBook.Worksheets("Sheet1").Range("A1")
End Sub
Remove this line Set WS = Sheets.Add and try..
Also you can modify line rng.Copy newBook.Worksheets("Sheet1").Range("A1") as **rng.copy newbook.Worksheets(1).Range ("A1")**
I have a workbook with a master sheet for school report cards. I have a macro applied to a button for exporting information from the master sheet to separate, newly-generated sheets in the same workbook. A1:C71 is the template and goes to every new sheet, and the following columns of info, from D1:71 to Q1:71, each appear in separate sheets (always in D1:71).
Here's the screenshot (http://imgur.com/a/ZDOVb), and here's the code:
`Option Explicit
Sub parse_data()
Dim studsSht As Worksheet
Dim cell As Range
Dim stud As Variant
Set studsSht = Worksheets("Input")
With CreateObject("Scripting.Dictionary")
For Each cell In studsSht.Range("D7:Q7").SpecialCells(xlCellTypeConstants, xlTextValues)
.Item(cell.Value) = .Item(cell.Value) & cell.EntireColumn.Address(False, False) & ","
Next
For Each stud In .keys
Intersect(studsSht.UsedRange, studsSht.Range(Left(.Item(stud), Len(.Item(stud)) - 1))).Copy Destination:=GetSheet(CStr(stud)).Range("D1")
Next
End With
studsSht.Activate
End Sub
Function GetSheet(shtName As String) As Worksheet
On Error Resume Next
Set GetSheet = Worksheets(shtName)
If GetSheet Is Nothing Then
Set GetSheet = Sheets.Add(after:=Worksheets(Worksheets.Count))
GetSheet.Name = shtName
Sheets("Input").Range("A1:C71").Copy
GetSheet.Range("A1:D71").PasteSpecial xlAll
GetSheet.Range("A1:B71").EntireColumn.ColumnWidth = 17.57
GetSheet.Range("C1:C71").EntireColumn.ColumnWidth = 54.14
GetSheet.Range("D1:D71").EntireColumn.ColumnWidth = 22
End If
End Function`
I would now like to create a separate button to split the sheets into separate workbooks so that the master sheet can be kept for record keeping and the individual workbooks can be shared with parents online (without divulging the info of any kid to parents other than their own). I would like the workbooks to be saved with the existing name of the sheet, and wonder if there's a way to have the new workbooks automatically saved in the same folder as the original workbook without having to input a path name? (It does not share the same filename as any of the sheets).
I tried finding other code and modifying it, but I just get single blank workbooks and I need as many as have been generated (preferably full of data!), which varies depending on the class size. Here's the pathetic attempt:
`Sub split_Reports()
Dim splitPath As String
Dim w As Workbook
Dim ws As Worksheet
Dim i As Long, j As Long
Dim lastr As Long
Dim wbkName As String
Dim wksName As String
Set wsh = ThisWorkbook.Worksheets(1)
splitPath = "G:\splitWb\"
Set w = Workbooks.Add
For i = 1 To lastr
wbkName = ws
w.Worksheets.Add(After:=w.Worksheets(Worksheets.Count)).Name = ws
w.SaveAs splitPath
w.Close
Set w = Workbooks.Add
Next i
End Sub`
I have learned so much, and yet I know so little.
Maybe this will start you off, just some simple code to save each sheet as a new workbook. You would probably need some check that the sheet name is a valid file name.
Sub x()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
ws.Copy
ActiveWorkbook.Close SaveChanges:=True, Filename:=ws.Name & ".xlsx"
Next ws
End Sub
I need to create a macro in my CountResults.xlsm (Master Workbook) that solves the following problem. I have a column of data in another worksheet with either YES or NO. I need to come up with a macro that counts the amount of "YES" in the column. The column is located in Sheet2 of the workbook Test01.xlsx. Then take that count and put it in one cell in my CountResults.xlsm file. Like so:
I have a code that displays a count for a column in the same sheet. But this code does not count when there are 'breaks' in the column (empty spaces) like I have in my picture. This is that code:
Private Sub CommandButton1_Click()
MsgBox Range("A1").End(xlDown).Row
Range("A1").End(xlDown).Offset(1, 0).Select
End Sub
I have another code that helps with accessing another workbook and defining values for each workbook and worksheet:
Dim wbSource As Workbook
Dim wbTarget As Workbook
Dim shSource As Worksheet
Dim shTarget As Worksheet
Set wbSource = Workbooks.Open(Filename:="C:\Users\khanr1\Desktop\Test_Excel\Test03.xlsm", ReadOnly:=True)
Set wbTarget = ThisWorkbook
Set shSource = wbSource.Worksheets("Sheet2")
Set shTarget = wbTarget.Worksheets("Sheet1")
Use COUNTIF. It will give you the total even if the range is in another workbook. i.e. =COUNTIF([Book2.xlsx]Sheet2!$D$2:$D$9, "Yes"). Problem with having COUNTIF within your sheet as a formula is that you will need to open the other workbook if you want the count to be update. Below VBA code will perform an update for you. Assign the sub to a button in your CountResults.xlsm workbook
EDIT: Added row count as per OP's requirement
Sub UpdateResults()
Dim oWBWithColumn As Workbook: Set oWBWithColumn = Application.Workbooks.Open("<your Test01.xlsx address here>")
Dim oWS As Worksheet: Set oWS = oWBWithColumn.Worksheets("Sheet2")
Dim intLastRow as Integer: intLastRow = oWS.Cells(Rows.Count, "B").End(xlUp).Row
ThisWorkbook.Worksheets("<name of the sheet in your CountResults.xlsm workbook>").Range("<cell address>").Value = Application.WorksheetFunction.CountIf(oWS.Range("B2:B" & intLastRow), "yes")
oWBWithColumn.Close False
Set oWS = Nothing
Set oWBWithColumn = Nothing
End Sub
I keep having this issue of VBA either not having an object for the new sheet I want to merge, or having the subscript out of range issue come up. None of the things I tried ended up working.
Private Sub MergeButton_Click()
Dim filename As Variant
Dim wb As Workbook
Dim s As Sheet1
Dim thisSheet As Sheet1
Dim lastUsedRow As Range
Dim j As Integer
On Error GoTo ErrMsg
Application.ScreenUpdating = False
Set thisSheet = ThisWorkbook.ActiveSheet
MsgBox "Reached method"
'j is for the sheet number which needs to be created in 2,3,5,12,16
For Each Sheet In ActiveWorkbook.Sheets
For i = 0 To FilesListBox.ListCount - 1
filename = FilesListBox.List(i, 0)
'Open the spreadsheet in ReadOnly mode
Set wb = Application.Workbooks.Open(filename, ReadOnly:=True)
'Copy the used range (i.e. cells with data) from the opened spreadsheet
If FirstRowHeadersCheckBox.Value And i > 0 Then 'Only include headers from the first spreadsheet
Dim mr As Integer
mr = wb.ActiveSheet.UsedRange.Rows.Count
wb.ActiveSheet.UsedRange.Offset(3, 0).Resize(mr - 3).Copy
Else
wb.ActiveSheet.UsedRange.Copy
End If
'thisSheet = ThisWorkbook.Worksheets(SheetCurr)
'Paste after the last used cell in the master spreadsheet
If Application.Version < "12.0" Then 'Excel 2007 introduced more rows
Set lastUsedRow = thisSheet.Range("A65536").End(xlUp)
Else
Set lastUsedRow = thisSheet.Range("A1048576").End(xlUp)
End If
'Only offset by 1 if there are current rows with data in them
If thisSheet.UsedRange.Rows.Count > 1 Or Application.CountA(thisSheet.Rows(1)) Then
Set lastUsedRow = lastUsedRow.Offset(1, 0)
End If
lastUsedRow.PasteSpecial
Application.CutCopyMode = False
Next i
This is where I try to add an extra loop that copies the next sheet (which is Sheet12) but it comes up with the Subscript our of range error.
Sheets("Sheet3").Activate
Sheet.Copy After:=ThisWorkbook.Sheets
Next Sheet
It will then move to the next sheet to perform the loop again.
ThisWorkbook.Save
Set wb = Nothing
#If Mac Then
'Do nothing. Closing workbooks fails on Mac for some reason
#Else
'Close the workbooks except this one
Dim file As String
For i = 0 To FilesListBox.ListCount - 1
file = FilesListBox.List(i, 0)
file = Right(file, Len(file) - InStrRev(file, Application.PathSeparator, , 1))
Workbooks(file).Close SaveChanges:=False
Next i
#End If
Application.ScreenUpdating = True
Unload Me
ErrMsg:
If Err.Number <> 0 Then
MsgBox "There was an error. Please try again. [" & Err.Description & "]"
End If
End Sub
Any help an this would be great
Your source code is very confusing and I believe you're stumbling because the ActiveWorkbook and ActiveSheet change each time you open a new workbook. It's also not clear why you're copying/merging the data from each worksheet in every opened workbook and then copying Sheet3. You will help yourself by more clearly defining what and where your data is and how you're moving it around.
As an example (that may not solve your problem, because your problem is not clear), look at the code below to see how you can keep the sources and destinations straight within your loops. Modify this example as much as you need in order to match your exact situation.
Sub Merge()
'--- assumes that each sheet in your destination workbook matches a sheet
' in each of the source workbooks, then copies the data from each source
' sheet and merges/appends that source data to the bottom of each
' destination sheet
Dim destWB As Workbook
Dim srcWB As Workbook
Dim destSH As Worksheet
Dim srcSH As Worksheet
Dim srcRange As Range
Dim i As Long
Application.ScreenUpdating = False
Set destWB = ThisWorkbook
For i = 0 To FileListBox.ListCount - 1
Set srcWB = Workbooks.Open(CStr(FileListBox(i, 0)), ReadOnly:=True)
For Each destSH In destWB.Sheets
Set srcSH = srcWB.Sheets(destSH.Name) 'target the same named worksheet
lastdestrow = destSH.Range("A").End(xlUp)
srcSH.UsedRange.Copy destSH.Range(Cells(lastdestrow, 1))
Next destSH
srcWB.Close
Next i
Application.ScreenUpdating = True
End Sub
I have a macro that copy/pastes a selection from one worksheet (Sheet1), to another worksheet (Notes). It works well. Now I want to first check if that worksheet exists. If it does not exist, I want to create it, then continue with the copy/pasting the selection.
When the "Notes" worksheet exists, the copy/paste works fine.
If the worksheet does not exist, it creates it, but the paste operation doesn't work. I don't get any errors. I have to rerun the macro and then the paste works (since the worksheet has already been created). Any ideas on what I missed?
Sub Copy2sheet()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim mySheetName As String, mySheetNameTest As String
mySheetName = "Notes"
'create worksheet at end of workbook if it does not exist
On Error Resume Next
mySheetNameTest = Worksheets(mySheetName).Name
If Err.Number = 0 Then
GoTo CopyPasteSelection
Else
Err.Clear
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = mySheetName
End If
'copy/paste selection to Notes worksheet
CopyPasteSelection:
Set copySheet = Worksheets("Sheet1")
Set pasteSheet = Worksheets("Notes")
Selection.Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).PasteSpecial xlPasteAll
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
When you do the Add, the activesheet becomes the new worksheet and your previous Selection is lost...............you must "remember" it before the Add:
Sub Copy2sheet()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Dim mySheetName As String, mySheetNameTest As String
mySheetName = "Notes"
Dim RtoCopy As Range
Set RtoCopy = Selection
'create worksheet at end of workbook if it does not exist
On Error Resume Next
mySheetNameTest = Worksheets(mySheetName).Name
If Err.Number = 0 Then
GoTo CopyPasteSelection
Else
Err.Clear
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = mySheetName
End If
'copy/paste selection to Notes worksheet
CopyPasteSelection:
Set copySheet = Worksheets("Sheet1")
Set pasteSheet = Worksheets("Notes")
RtoCopy.Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).PasteSpecial xlPasteAll
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Pay attention to the three lines referencing RtoCopy .
You have On Error Resume Next in your code. First time through it goes on its merry way. The second time through the Error check triggers the creation of the new tab.
On Error Resume Next is bad. Don't use it.
See this question for more information on solving your problem How to check whether certain sheets exist or not in Excel-VBA?
You should first activate and select the sheet and range to be copied. This works.
CopyPasteSelection:
Set copySheet = Worksheets("Sheet1")
Set pasteSheet = Worksheets("Notes")
Worksheets("Sheet1").Activate 'Activete "Sheet1"
Worksheets("Sheet1").Range("A1").Select 'Select the range to be copied
'Then copy selection
Selection.Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).PasteSpecial xlPasteAll
Application.CutCopyMode = False
Application.ScreenUpdating = True
I suggest using Function for more re-usability:
A dirty and fast way:
Function isWorksheetValid(wsName As String)
ON Error Goto ErrHndl
Dim ws as Worksheet
Set ws = Sheets(wsName)
isWorksheetValid = True
Exit Function
ErrHndl:
isWorksheetValid = False
End Function
A correct but a bit slower way:
Function isWorksheetValid(wsName As String)
ON Error Goto ErrHndl
Dim ws as Worksheet
For Each ws in Sheets
If (UCASE(ws.Name) = UCASE(wsName)) Then
isWorksheetValid = True
Exit Function
End If
Next
ErrHndl:
isWorksheetValid = False
End Function
Now you need just use it like this:
If (isWorksheetValid(mySheetName) Then
' Add your code here
End If