I am trying to resize an Excel table to standard setting of 4 rows and 6 columns
I am able to do for the columns but I still see the empty rows based on the content earlier.
Sub ClearTableContents()
Dim wrksht As Worksheet
Dim objListObj As ListObjects
Dim tableName As String
Dim ActiveTable As ListObject
Dim ActiveRange As Range
Set wrksht = ActiveWorkbook.Worksheets("Sheet1")
Set objListObj = wrksht.ListObjects
With objListObj
For i = 1 To objListObj.Count
tableName = objListObj(i).Name
Set ActiveTable = ActiveSheet.ListObjects(tableName)
'ActiveTable.DataBodyRange.Rows.ClearContents
objListObj(i).DataBodyRange.Rows.ClearContents
On Error Resume Next
'objListObj(i).DataBodyRange.Resize(objListObj(i).DataBodyRange.Rows.Count - 4,
objListObj(i).DataBodyRange.Columns.Count - 6).Rows.Delete
objListObj(i).DataBodyRange.Resize(4, 6).Rows.Delete
If Err.Number <> 0 Then
' process Error
MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical
End If
Next i
End With
End Sub
This will leave the header and three rows so adjust to suit.
Sub x()
With ActiveSheet.ListObjects(1)
.Range.Rows("5:" & .Range.Rows.Count).Delete
.Resize .Range.Resize(4, 6)
End With
End Sub
Related
I have a survey with health data from patients. I have a sheet with all the data named "data",
This is how the data sheet looks like, each column being some category from the patient (there are more rows):
I am creating a macro where the user has to select a Health Authority from a drop-down box, and that will create a new sheet named as the health authority selected. The button assigned to the macro is on another sheet called "user".
This is my code so far:
EDIT: I added sub demo () to try and paste it but it did not work. It says variable not defined in the part " With Sheets(sName)"
Option Explicit
Sub createsheet2()
Dim sName As String, ws As Worksheet
sName = Sheets("user").Range("M42").Value
' check if already exists
On Error Resume Next
Set ws = Sheets(sName)
On Error GoTo 0
If ws Is Nothing Then
' ok add
Set ws = Sheets.Add(after:=Sheets(Sheets.Count))
ws.Name = sName
MsgBox "Sheet created : " & ws.Name, vbInformation
Else
' exists
MsgBox "Sheet '" & sName & "' already exists", vbCritical, "Error"
End If
End Sub
Sub demo()
Const COL_HA = 6 ' F
Dim id As Long, rng As Range
id = 20 ' get from user dropdown
With Sheets("user")
.AutoFilterMode = False
.UsedRange.AutoFilter field:=COL_HA, Criteria1:=id
Set rng = .UsedRange.SpecialCells(xlVisible)
End With
' new sheet
'here is the problem
With Sheets(sName)
rng.Copy .Range("A1")
.Range("A1").Activate
End With
End Sub
I need to write the code that inserts in the new sheet only the data of the patients of the chosen Health Authority. Each Health Authority corresponds to a number
"sha" column is the health authority that the user previously selected.
Does anyone know how to insert the data I need to this new created sheet?
I think that I need to filter the data first and then paste it inside the sheet. I am very new at VBA and I'm lost.
Replace your code with this
Option Explicit
Sub createsheet()
Const COL_HA = 6 ' F on data sheet is Health Auth
Dim sName As String, sId As String
Dim wsNew As Worksheet, wsUser As Worksheet
Dim wsIndex As Worksheet, wsData As Worksheet
Dim rngName As Range, rngCopy As Range
With ThisWorkbook
Set wsUser = .Sheets("user")
Set wsData = .Sheets("data")
Set wsIndex = .Sheets("index")
End With
' find row in index table for name from drop down
sName = Left(wsUser.Range("M42").Value, 30)
Set rngName = wsIndex.Range("L5:L32").Find(sName)
If rngName Is Nothing Then
MsgBox "Could not find " & sName & " on index sheet", vbCritical
Else
sId = rngName.Offset(, -1) ' column to left
End If
' create sheet but check if already exists
On Error Resume Next
Set wsNew = Sheets(sName)
On Error GoTo 0
If wsNew Is Nothing Then
' ok add
Set wsNew = Sheets.Add(after:=Sheets(Sheets.Count))
wsNew.Name = sName
MsgBox "Sheet created : " & wsNew.Name, vbInformation
Else
' exists
MsgBox "Sheet '" & sName & "' already exists", vbCritical, "Error"
Exit Sub
End If
' filter sheet and copy data
Dim lastrow As Long, rngData As Range
With wsData
lastrow = .Cells(.Rows.Count, COL_HA).End(xlUp).Row
Set rngData = .Range("A10:Z" & lastrow)
.AutoFilterMode = False
rngData.AutoFilter Field:=COL_HA, Criteria1:=sId
Set rngCopy = rngData.SpecialCells(xlVisible)
.AutoFilterMode = False
End With
' new sheet
With wsNew
rngCopy.Copy .Range("A1")
.Range("A1").Activate
End With
MsgBox "Data for " & sId & " " & sName _
& " copied to wsNew.name", vbInformation
End Sub
I have a Workbook that has a "live" tab, which has around 8 Queries.
Everyday I duplicate this sheet, before refreshing. In the duplicated sheet, I would like to remove all queries, as i dont need them anymore.
I'm trying to create a macro to remove all Queries.
I tried following code, but it doesn't work. error: object doesn't support this method for the line 5.
Sub DelQueries()
Dim q As WorkbookQuery
For Each q In ActiveWorkbook.Queries
If q.Parent.Name = ActiveSheet.Name Then
q.Delete
End If
Next
End Sub
I also tried the code from this question, with some modification, but gets syntax error for line 3.
Sub loop_del_query()
For Each Worksheet In ThisWorkbook.Worksheets
If Worksheet.Name = ActiveSheet.Name
Qcount = Worksheet.Queries.Count
If Qcount > 0 Then
For Each Query In Worksheet.Queries
Query.Delete
Next
End If
End If
Next Worksheet
End Sub
As explained on this post try ;
Option Explicit
Sub DeleteQueries()
Dim wb As Workbook, ws As Worksheet
Dim wq As WorkbookQuery, qname As String
Dim qt As QueryTable, tbl As ListObject
Dim msg As String, dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
' existing queries
For Each wq In wb.Queries
dict.Add wq.Name, 1
Next
' scan table object for query tables
For Each tbl In ws.ListObjects
Set qt = Nothing
On Error Resume Next
Set qt = tbl.QueryTable
On Error GoTo 0
If Not qt Is Nothing Then
qname = qt.WorkbookConnection.Name
If Left(qname, 8) = "Query - " Then
qname = Mid(qname, 9)
'Debug.Print tbl.Name & " Query:" & qname
'delete query if exists
If dict.exists(qname) Then
wb.Queries(qname).Delete
msg = msg & vbCrLf & qname
Else
Debug.Print "Not found", qname
End If
End If
End If
Next
If msg = "" Then
MsgBox "No Queries deleted", vbInformation
Else
MsgBox "Queries deleted:" & msg, vbInformation
End If
End Sub
there.
I'm trying to retrieve comments from a pre-defined name range of cells, but I keep getting the error message for the instruction: Set c = Range("myRange").Comment.Value
Only the active workbook is open, range is there, etc.
In the meantime, a value has been assigned to c, that corresponds to very first cell of myRange.
Any ideas? thanks a lot.
Sub Test_findComments_in_range()
Dim varComment As String
Dim c As Variant
With ActiveSheet
For Each c In .Range("myRange")
Set c = Range("myRange").Comment.Value
If IsEmpty(c) Then
MsgBox "No comment found! "
GoTo jumpCycle3
Else
varComment = c.Value
MsgBox varComment, vbInformation
End If
jumpCycle3: Next
End With
End Sub
There is no need to go through all the cells in the range and check each one for a comment, you can use the Range.SpecialCells method with the parameter xlCellTypeComments
Sub ListComments()
Dim rng As Range
Set rng = ActiveSheet.Range("myRange")
On Error GoTo out ' handle the error that occurs if there is no cell with comments
Set rng = rng.SpecialCells(xlCellTypeComments)
On Error GoTo 0
For Each cl In rng ' iterate over all cells in rng - each of them contains a comment
MsgBox cl.Address & " : " & cl.Comment.Text, vbInformation
Next
Exit Sub
out: MsgBox "No comments in the area"
End Sub
Find Comments in a Named Range
Option Explicit
Sub FindCommentsInNamedRange()
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the named range ('rg').
Dim rg As Range: Set rg = wb.Names("myRange").RefersToRange
' To reference the range's worksheet (not necessary here), you could use:
'Dim ws As Worksheet: Set ws = rg.Worksheet
Dim cell As Range
Dim cm As Comment
Dim cText As String
' Loop through the cells of the range (note 'rg.Cells')...
For Each cell In rg.Cells
' Attempt to reference the cell's comment ('cm').
Set cm = cell.Comment
' Validate the comment.
If cm Is Nothing Then
MsgBox "No comment found!", vbExclamation, _
"Comment in Cell '" & cell.Address(0, 0) & "'"
Else
' Write the comment's text to a variable ('cText').
cText = cm.Text
MsgBox cText, vbInformation, _
"Comment in Cell '" & cell.Address(0, 0) & "'"
End If
Next cell
End Sub
I have a spreadsheet with two columns of data, both columns have a header. I would like to establish a variable for each row of data I can then use to generate new worksheet names and insert into formulas. My variable would be a one to one ratio with the data, meaning A2-B2, A3-B3, etc. I have tried the following code:
'''Sub CreateSheet2()
Dim rngBP As Range
Dim rngCon As Range
Dim cellBP As Range
Dim cellCon As Range
On Error GoTo Errorhandling
Set rngBP = Application.InputBox(prompt:="Bid Package Select Cell Range:", Title:="Create Sheets", Default:=Selection.Address, Type:=8)
Set rngCon = Application.InputBox(prompt:="Contractor Select Cell Range:", Title:="Create Sheets", Default:=Selection.Address, Type:=8)
For Each cellBP In rngBP
If cellBP <> "" And cellCon <> "" Then
Sheets.Add(after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)).Name = cellBP & "-" & cellCon
End If
Next cellBP
Errorhandling:
MsgBox prompt:="Error Detected" & vbNewLine & "Error" & Err.Number & ": " & Err.Description
End Sub'''
However, this code generates a variable with all of the possible combinations (A2-B2, A2-B3, A3-B3, etc.). Ideally, this code would also skip empty cells and not create a variable for that entire row. Here is a screenshot of my sample dataset.Sample Dataset. Thank you for the assistance.
Add Worksheets with Names Created from Two Columns
I see the double Application.InputBoxes as a disaster waiting to happen so I abandoned the idea.
The code will search for the specified headers in the first row and their columns will define the column ranges (from the 2nd to the last row).
Copy the code into a standard module, e.g. Module1.
Adjust the four constants.
You only run the first procedure which will call the second when needed.
The third procedure is showing an example of proper error handling. Study it closely.
The Code
Option Explicit
Sub CreateSheet2()
'On Error GoTo ErrorHandling
Const wsName As String = "Sheet1"
Const bTitle As String = "Bid Package"
Const cTitle As String = "Contractor"
Const FirstRow As Long = 2
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
Dim ws As Worksheet
Set ws = wb.Worksheets(wsName)
Dim bCol As Variant
bCol = Application.Match(bTitle, ws.Rows(1), 0)
Dim cCol As Variant
cCol = Application.Match(cTitle, ws.Rows(1), 0)
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, bCol).End(xlUp).Row
Dim ColumnOffset As Long
ColumnOffset = cCol - bCol
Dim SheetNames As Variant
SheetNames = getSheetNames(wb)
Dim rng As Range
Set rng = ws.Cells(FirstRow, bCol).Resize(LastRow - FirstRow + 1)
Dim cel As Range
Dim SheetName As String
For Each cel In rng.Cells
If cel.Value <> "" And cel.Offset(, ColumnOffset).Value <> "" Then
SheetName = cel.Value & "-" & cel.Offset(, ColumnOffset).Value
If IsError(Application.Match(SheetName, SheetNames, 0)) Then
On Error Resume Next
wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count)).Name _
= SheetName
If Err Then ' might happen if there are duplicates in columns.
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
End If
On Error GoTo ErrorHandling
End If
End If
Next cel
ProcExit:
Exit Sub
ErrorHandling:
MsgBox Prompt:="Error Detected" & vbNewLine & "Error '" & Err.Number _
& "': " & Err.Description, _
Buttons:=vbCritical, _
Title:="Fail"
Resume ProcExit
End Sub
Function getSheetNames(Book As Workbook) _
As Variant
If Book Is Nothing Then
GoTo ProcExit
End If
Dim Data As Variant
ReDim Data(1 To Book.Sheets.Count)
Dim sh As Object
Dim n As Long
For Each sh In Book.Sheets
n = n + 1
Data(n) = sh.Name
Next sh
getSheetNames = Data
ProcExit:
End Function
Proper Error Handling
Sub ProperErrorHandling()
On Error GoTo ErrorHandling
' The code
ProcExit:
Exit Sub ' You don't want to show the message if no error and
' you must not 'Resume' with no error!
ErrorHandling:
MsgBox Prompt:="Error Detected" & vbNewLine & "Error '" & Err.Number _
& "': " & Err.Description, _
Buttons:=vbCritical, _
Title:="Fail"
' Sets the error number to 0, but still keeps the error handler active.
' Therefore be aware that if you put code between 'ProcExit' and 'Exit Sub'
' and an error occurs, it will result in an endless loop.
Resume ProcExit ' 'Resume', not 'GoTo'!
End Sub
Please try this code.
Sub CreateSheet2()
Const BidPack As String = "A" ' specify a column
Const Contractor As String = "B" ' change to suit (to the right of BidPack)
Const FirstDataRow As Long = 2 ' change to suit
Dim Wb As Workbook
Dim Ws As Worksheet
Dim BidRng As Range
Dim ConRng As Range
Dim Tmp As Variant ' misc use
Dim WsName As String
Dim R As Long ' loop counter: rows
Set Wb = ActiveWorkbook ' change to suit
WsName = "Sheet1" ' change to suit
Application.ScreenUpdating = False
Tmp = Columns(Contractor).Column
With Wb.Worksheets(WsName)
Set ConRng = .Range(.Cells(FirstDataRow, Tmp), _
.Cells(.Rows.Count, Tmp).End(xlUp))
' ConRng and BidRng are of identical size,
' not exceeding the number of rows available in ConRng.
Set BidRng = ConRng.Offset(, Columns(BidPack).Column - Tmp)
For R = 1 To BidRng.Cells.Count
If (Not IsEmpty(BidRng.Cells(R))) And (Not IsEmpty(ConRng.Cells(R))) Then
WsName = Format(BidRng.Cells(R).Value, "00-") & ConRng.Cells(R).Value
On Error Resume Next
Set Tmp = Wb.Sheets(WsName)
If Err Then
Wb.Sheets.Add(After:=Wb.Sheets(Wb.Sheets.Count)).Name = WsName
Else
MsgBox "A worksheet by the name of """ & WsName & _
""" already exists.", vbInformation, _
"Duplicate instruction"
End If
End If
Next R
End With
Application.ScreenUpdating = False
End Sub
I think it's best
loop through rngBP range not empty values, only
using a Dictionary object to ensure you're not duplicating sheet names
Option Explicit
Sub CreateSheets()
Dim rngBP As Range
Dim cellBP As Range
On Error GoTo Errorhandling
Set rngBP = Application.InputBox(prompt:="Bid Package Select Cell Range:", Title:="Create Sheets", Default:=Selection.Address, Type:=8)
Dim shNamesDict As Object
Set shNamesDict = CreateObject("Scripting.Dictionary")
With ActiveWorkbook
Dim shName As String
For Each cellBP In rngBP.SpecialCells(xlCellTypeConstants)
If Not IsEmpty(cellBP.Offset(, 1).Value2) Then
shName = cellBP.Value2 & "-" & cellBP.Offset(, 1).Value2
If Not shNamesDict.exists(shName) Then
shNamesDict.Add shName, 0
.Sheets.Add(after:=.Worksheets(.Worksheets.Count)).Name = shName
End If
End If
Next
End With
Errorhandling:
If Err.Number <> 0 Then MsgBox prompt:="Error Detected" & vbNewLine & "Error" & Err.Number & ": " & Err.Description
End Sub
I am trying to display all comment text for each worksheet in the Activeworkbook in a MsgBox (for each comment).
My code isn't throwing an error, so I know I am close.
Sub ShowAllWorkbookcomments()
On Error Resume Next
Dim ws As Worksheet
Dim rng As Range
Dim cell As Variant
Dim cmt As String
Dim commentcount As Integer
Set ws = ActiveWorkbook.Worksheets(1)
Set rng = ActiveSheet.Cells.SpecialCells(xlCellTypeComments)
commentcount = rng.Count
'cmt = ws.rng.Comment.Text
Dim varComment As String
Dim c As Comment
For Each ws In ActiveWorkbook.Worksheets
Select Case commentcount
Case 0
MsgBox "No Comment", vbExclamation
Resume Next
Case Is > 0
For Each cell In rng
varComment = c.Text
MsgBox varComment, vbInformation
Next cell
End Select
Set rng = Nothing
Next ws
End Sub
You were close, just needed to get the Set rng = ActiveSheet.Cells.SpecialCells(xlCellTypeComments) inside the For Each ws In ActiveWorkbook.Worksheets loop.
Also, added another way to trap the possibility of a worksheet having no comments, and removed the unnecessary Select Case.
Try the code below:
Option Explicit
Sub ShowAllWorkbookcomments()
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim cmt As String
Dim varComment As String
For Each ws In ActiveWorkbook.Worksheets
On Error Resume Next
Set rng = ws.Cells.SpecialCells(xlCellTypeComments)
On Error GoTo 0
If Not rng Is Nothing Then '<-- current worksheet has comments
For Each cell In rng.Cells
'varComment = cell.Comment.text
varComment = "worksheet " & ws.Name & " comment " & cell.Comment.text ' <-- added the worksheet name as reference
MsgBox varComment, vbInformation
Next cell
Else '<-- current worksheet has No comments >> rng is Nothing
'MsgBox "No Comment", vbExclamation
MsgBox "worksheet " & ws.Name & " has No Comments", vbExclamation ' <-- added the worksheet name as reference
End If
Set rng = Nothing
Next ws
End Sub
As mentioned in one of the comments above, the above logic will cause the MsgBox to be shown for each of the cells in a merged range. The following logic will loop-through the comments in a given sheet, it will work for merged rows/cols scenario as well.
For Each CommentedSheets In ActiveWorkbook.Worksheets
If CommentedSheets.Comments.Count = 0 Then
MsgBox "worksheet " & CommentedSheets.Name & " has No Comments", vbExclamation
Else
For Each Individual_Comment In CommentedSheets.Comments
varComment = "worksheet " & CommentedSheets.Name & " comment " & Individual_Comment.text
MsgBox varComment, vbInformation