I have made a macro which collapses an certain number of columns based on an input sheet. The macro is running, when the user is activating the sheet(s), as seen below.
Worksheet_Activate macro:
Private Sub Worksheet_Activate()
ActiveSheet.Unprotect "mypassword"
Call collapsecolumns
ActiveSheet.Protect "mypassword"
End sub
The macro which is called:
Public Sub collapsecolumns()
Dim ws1 As Worksheet: Set ws1 = Sheets("inputSheet")
Dim ws2 As Worksheet: Set ws2 = ActiveSheet
Dim sheetNo As Integer, colToCollapse As Integer
'number in sheet name define range for counting columns to collapse
sheetNo = Right(ws2.Name, 1)
'input range differs depending on which sheet is chosen
colToCollapse = Application.WorksheetFunction.CountA(ws1.Range("J" & ((6 * sheetNo) - 4) & ":J" & ((6 * sheetNo) + 1)))
ws2.Range(Cells(1, 1), Cells(1, 35)).EntireColumn.Hidden = False
If colToCollapse = 0 Then
Exit Sub
End If
ws2.Range(Cells(1, colToCollapse * 6), Cells(1, 35)).EntireColumn.Hidden = True
End Sub
However, when the sheet is activated, you seen the columns collapse (or uncollapse) depending on what you wrote in the other sheet. I've various combination and placements of ScreenUpdate=False and EntireEvents=False to mask the collapsing, but without success
Is there any way, that the user first sees the sheet, when the columns have been collapsed, when using Worksheet_Activate()?
I have added two lines of code so that the user can view when the columns get hidden
Public Sub collapsecolumns()
Dim ws1 As Worksheet: Set ws1 = Sheets("inputSheet")
Dim ws2 As Worksheet: Set ws2 = ActiveSheet
Dim sheetNo As Integer, colToCollapse As Integer
'number in sheet name define range for counting columns to collapse
sheetNo = Right(ws2.Name, 1)
'input range differs depending on which sheet is chosen
colToCollapse = Application.WorksheetFunction.CountA(ws1.Range("J" & ((6 * sheetNo) - 4) & ":J" & ((6 * sheetNo) + 1)))
ws2.Range(Cells(1, 1), Cells(1, 35)).EntireColumn.Hidden = False
If colToCollapse = 0 Then
Exit Sub
End If
ActiveWindow.ScrollColumn = 32
Application.Wait (Now + TimeValue("0:00:1"))
ws2.Range(Cells(1, colToCollapse * 6), Cells(1, 35)).EntireColumn.Hidden = True
End Sub
It will first move the excel sheet to the columns which will hide
then it will wait for 1 second and then hide the columns
I hope this is what you were looking for...
Related
i did this code that works pretty well exept the last part:
The behaviour of last part should be that ".Interior.Color" and ".Value" affected until the last populated column, instead it affects the first cell of many other columns. Any ideas?
Sub Sample_Workbook()
'Creation of new workbook
Application.ScreenUpdating = False
Workbooks.Add
Set wb = ActiveWorkbook
wb.SaveAs ThisWorkbook.Path & "etc.xlsx"
'following variable is declared for sending mail purpose
SourceWorkbook = ActiveWorkbook.Name
Set this = Workbooks("Sample")
Set wb = ActiveWorkbook
Set ws1 = wb.Sheets("Sheet1")
wb.Sheets.Add After:=Sheets(1)
Set ws2 = wb.Sheets(2)
wb.Sheets.Add After:=Sheets(2)
Set ws3 = wb.Sheets(3)
ws1.Name = "Sheet1"
ws2.Name = "Sheet2"
ws3.Name = "Sheet3"
'Model the new excel with the requirements:
Dim Population, Population2 As Range
Dim lastRow As Long, firstRow As Long
Dim sampleSize As Long
Dim unique As Boolean
Dim i As Long, d As Long, n As Long
'following function perfoms all the calculations and copy and pasting
doTheJob x, y, z, num, q
doTheJob x, y, z, num, q
doTheJob x, y, z, num, q
'copy and paste the remaining sheets from the sample files
Workbooks.Open ThisWorkbook.Path & "Sample2.xlsx"
Sheets("Sheetx").Copy After:= _
Workbooks(SourceWorkbook).Sheets(6)
Workbooks("Sample2.xlsx").Close SaveChanges:=False
Application.ScreenUpdating = True
Application.CutCopyMode = False
ws1.Select
wb.Close SaveChanges:=True
End Sub
'these will make the variable available to all modules of this macro Workbook
Public SourceWorkbook As String
Public this, wb As Workbook
Public data As Range
Public output As Range
Public ws1, ws2, ws3 As Worksheet
Public LastCol As Long
Public wks As Worksheet
Public iCol As Long
'FUNCTION
Sub doTheJob(x As String, y As String, z As String, num As Integer, q As String)
'beginning logic.
this.Worksheets(x).Activate
Set Population = Range("a3", Range("a3").End(xlDown))
sampleSize = this.Worksheets("SNOW Reports").Range(y).Value
Set r = Population
lastRow = r.Rows.Count + r.Row - 1
firstRow = r.Row
For i = 1 To sampleSize
Do
unique = True
n = Application.WorksheetFunction.RandBetween(firstRow, lastRow)
For d = 1 To i - 1
'wb.Sheets(z).Activate
If wb.Sheets(z).Cells(d + 1, 50) = n Then
unique = False
Exit For
End If
Next d
If unique = True Then
Exit Do
End If
Loop
Set data = this.Worksheets(x).Range("a" & n, Range("a" & n).End(xlToRight))
Set output = wb.Worksheets(z).Range("A" & i + 1)
output.Resize(data.Rows.Count, data.Columns.Count).Value = data.Value
'THE NEXT LINE IS JUST FOR DELETEING LAST COLUMN PURPOSE
wb.Worksheets(z).Cells(1, 50) = "REF COL"
wb.Worksheets(z).Cells(i + 1, 50) = n
this.Worksheets(x).Activate
Next i
'delete REF COL:
With wb.Sheets(z)
.Columns(50).Delete
End With
'copy and paste header:
Set data = this.Worksheets(x).Range("a2", Range("a2").End(xlToRight))
Set output = wb.Sheets(z).Range("A1")
output.Resize(data.Rows.Count, data.Columns.Count).Value = data.Value
'_________________________________________________________________________________________________________
'copy and paste into new sheet with recorded macro
wb.Activate
Sheets.Add(After:=Sheets(num)).Name = q
wb.Worksheets(z).Cells.Copy Destination:=wb.Worksheets(q).Range("A1")
'create columns and add color and text dinamically
For Each wks In ActiveWindow.SelectedSheets
With wks
For iCol = .Cells.SpecialCells(xlCellTypeLastCell).Column To 2 Step -1
.Columns(iCol).Insert
With Cells(1, iCol)
.Interior.Color = 65535
.Value = Cells(1, iCol - 1) & " - Comparison"
End With
Next iCol
End With
Next wks
End Sub
If I understand what you're aiming to do, the following does what you want.
The code could be approached differently (and possibly made more efficient), if the larger context was known
However, I sense this is just a stage in your development, so have stayed with your approach (wherever reasonable).
' I suggest this goes to the top of the sub (no need for public declaration)
' Note the shorthand declaration: 'lgRow&' is the same as `lgRow as Long'
Dim lgRow&, lgCol&, lgLastRow&
' Replaces the code starting with the next comment
'create columns and add color and text dynamically
For Each wks In ActiveWindow.SelectedSheets
With wks
For lgCol = .Cells.SpecialCells(xlCellTypeLastCell).Column To 2 Step -1
' Insert a column (not sure why you're not doing this after the last column also)
.Columns(lgCol).Insert
' Get last row with data in the column 1 to the left
With .Columns(lgCol - 1)
lgLastRow = .Cells(.Cells.Count).End(xlUp).Row
End With
' In the inserted column:
' o Set cell color
' o Set value to corresponding cell to the left, appending ' - Comparison'
For lgRow = 1 To lgLastRow
With .Cells(lgRow, lgCol)
.Interior.Color = 65535
.Value = .Offset(0, -1) & " - Comparison"
End With
Next lgRow
Next lgCol
End With
Next wks
Note 1: Not sure of the reason, but your code inserts the 'comparison columns' after each column, except the last column (of the copied data). If I understand your intent correctly, I'd assume you want to do this for the last column also. If that's true:
'change this line
For lgCol = .Cells.SpecialCells(xlCellTypeLastCell).Column To 2 Step -1
'To:
For lgCol = .Cells.SpecialCells(xlCellTypeLastCell).Column + 1 To 2 Step -1
Note 2: My code changes write <cell value> & " - Comparison" to all cells in each column, down to the last non-blank cell in each 'compared' column (including blank cells above that). If you want to do that write for all rows in the copied data range (whether cells are blank or not) you could simplify the code by placing the following:
' Insert this:
lgLastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
'above line:
For lgCol = ....
And remove this:
' Get last row with data in the column 1 to the left
With .Columns(iCol - 1)
lgLastRow = .Cells(.Cells.Count).End(xlUp).Row
End With
Other Note / Pointers:
Recommend Option Explicit at the top of all modules (just saves a lot of debugging due to typos)
There's no need (and it's not good practice) to declare Public variables that are only used locally in a given Sub or Function. Instead, declare same locally (usually at the top of the Sub or Function).
It's good practice to use the leading characters of variable names to ID the data type. Can be any length, but is commonly 1, 2 or 3 chars (coder's preference). e.g. Above I used lg to ID long data types. Similarly, I use in for Integer, st for String, rg for Range, etc.
I am creating a VBA Excel program where I can copy the cell value to another sheet if its corresponding checkbox is checked. I have 278 "number" entries in one column and an corresponding individual "checkboxes" in one column. But when click the checkbox, the corresponding row text is not displayed.Instead it shows only the first 5 column values. For example, If I select 5 checkboxes randomly, it shows 1,2,3,4,5 numbers are displayed in the "sheet 2" columns.
Sub Button21_Click()
Dim chkbx As CheckBox
Dim i As Integer
a = Worksheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a
For Each chkbx In ActiveSheet.CheckBoxes
If chkbx.Value = xlOn Then
Worksheets("sheet1").Cells(i, 1).Copy
Worksheets("sheet2").Activate
b = Worksheets("sheet2").Cells(i, 1).End(xlUp).Row
Worksheets("sheet2").Cells(b + 1, 1).Select
ActiveSheet.Paste
i = i + 1
End If
Next chkbx
Next i
End Sub
This is the code I've used.
Any help would be appreciated.
An Objects Investigation
The Solution
The TopLeftCell Solution, The Solution, is based on the idea of Tim Williams suggested in the comments.
This will be in your sheet code (Sheet1).
Sub Button21_Click()
executeCheckBoxes
End Sub
The rest will be in a standard module (e.g. Module1).
Sub executeCheckBoxes()
Dim src As Worksheet ' Source Worksheet (Object)
Dim tgt As Worksheet ' Target Worksheet (Object)
Dim chkbx As CheckBox ' CheckBox (For Each Control Variable)
Dim srcLR As Long ' Source Last Row
Dim tgtER As Long ' Target Empty Row
Dim i As Long ' Source Row Counter
Set src = ThisWorkbook.Worksheets("Sheet1")
Set tgt = ThisWorkbook.Worksheets("Sheet2")
srcLR = src.Cells(src.Rows.Count, 1).End(xlUp).Row
tgtER = tgt.Cells(tgt.Rows.Count, 1).End(xlUp).Row + 1
For Each chkbx In src.CheckBoxes
If chkbx.Value = xlOn Then
' Cell Version
tgt.Cells(tgtER, 1).Value = _
src.Cells(chkbx.TopLeftCell.Row, 1).Value
' The following 2 ideas are not so good. They are running into trouble
' when adding new checkboxes if not sooner.
' Index Version
' Assuming the index of the checkbox is 1 for row 2, 2 for 3 etc.
' Adjust the "+1" as needed.
' tgt.Cells(tgtER, 1).Value = src.Cells(chkbx.Index + 1, 1).Value
' Name Version
' Assuming the name of the checkbox is "Check Box 1" for row 2,
' "Check Box 2" for 3 etc. Adjust the "+1" as needed.
' tgt.Cells(tgtER, 1).Value = src.Cells(Val(Right(chkbx.Name, _
' Len(chkbx.Name) - Len("Check Box "))) + 1, 1).Value
tgtER = tgtER + 1
Debug.Print chkbx.Name
End If
Next chkbx
End Sub
Extras
The following are codes used to help to create the two inferior solutions.
Sub deleteCB()
deleteCheckBoxes ThisWorkbook.Worksheets("Sheet1")
End Sub
' Deletes all check boxes on a worksheet.
' Note: When you delete all check boxes, the 'counter' is not reset i.e. if you
' e.g. had "Check Box 100" the next check box will be named "Check Box 101".
' But after you save and close the workbook and open it again,
' the first check box name will be "Check Box 1".
Sub deleteCheckBoxes(Sheet As Worksheet)
Sheet.CheckBoxes.Delete
End Sub
' Creates check boxes in a range.
Sub addCheckBoxes()
Const SheetName As String = "Sheet1"
Const chkRange As String = "B2:B279"
Const chkCaption As String = "Chk"
Dim chk As CheckBox, rng As Range, cel As Range, i As Long
i = 1
With ThisWorkbook.Worksheets(SheetName)
Set rng = .Range(chkRange)
For Each cel In rng.Cells
Set chk = .CheckBoxes.Add(cel.Left, cel.Top, cel.Width, cel.Height)
With chk
.Caption = chkCaption & i
End With
i = i + 1
Next
End With
End Sub
Sub showSomeCheckBoxProperties()
Dim chk As CheckBox, rng As Range, cel As Range, i As Long
i = 1
With ThisWorkbook.Worksheets("Sheet1")
For Each chk In .CheckBoxes
With chk
Debug.Print .BottomRightCell.Address, .Caption, _
.Characters.Count, .Enabled, .Index, .Name, .Placement, _
.Text, .TopLeftCell.Address, .Value, .Visible
End With
Next
End With
End Sub
Extras 2
The following is the code based on the YouTube video
Add Button to Worksheet and Assign a Macro to it -Excel Help by XLorate that helped quite a lot in answering this question.
Sub addButtons()
Dim btn As Button, rng As Range, cel As Range, i As Long
i = 1
With ThisWorkbook.Worksheets("Sheet1")
Set rng = .Range("A1:A3")
For Each cel In rng.Cells
Set btn = .Buttons.Add(cel.Left, cel.Top, cel.Width, cel.Height)
With btn
.Caption = "Macro" & i
.OnAction = "Macro" & i
End With
i = i + 1
Next
End With
End Sub
The following are some other more or less helpful codes which I created while investigating objects.
Sub showSomeShapesProperties()
Dim ws As Worksheet, sh As Shape
Set ws = ThisWorkbook.Worksheets("Sheet1")
For Each sh In ws.Shapes
With sh
If sh.Type = 12 Then
Debug.Print .Name, .Type, .ID, .OnAction, .TopLeftCell.Address
End If
If sh.Type = 8 Then
Debug.Print .Name, .Type, .ID, .OnAction, .TopLeftCell.Address
End If
End With
Next
End Sub
Sub showSomeOleObjectProperties()
Dim ws As Worksheet, oo As OLEObject
Set ws = ThisWorkbook.Worksheets("Sheet1")
For Each oo In ws.OLEObjects
With oo
Debug.Print .Name, .OLEType, .AutoLoad, .Enabled, .Index, _
.BottomRightCell.Address
End With
Next
End Sub
Sub addOLECheckBoxes()
Const srcName As String = "Sheet1"
Dim chk As OLEObject, rng As Range, cel As Range, i As Long
With ThisWorkbook.Worksheets(srcName)
Set rng = .Range("A1:A10")
i = 1
For Each cel In rng.Cells
Set chk = .OLEObjects.Add(ClassType:="Forms.CheckBox.1", _
Left:=cel.Left, Top:=cel.Top, Width:=cel.Width, Height:=cel.Height)
With chk
'.Name = "Chk" & i
'.Placement = xlMoveAndSize
End With
i = i + 1
Next cel
End With
End Sub
This code copies the entries from Sheet1!A2, Sheet1!B2, etc. and pastes them onto Sheet2 with 3 rows between each entry. I want to duplicate this code without using .select.
Option Explicit
Sub Copy_Paste()
Dim i As Integer
For i = 1 To 100
Sheets("Sheet1").Select
Range("A2,B2,C2,D2,E2").Select
ActiveCell.Range(Cells(i, 1), Cells(i, 2)).Select
Selection.Copy
Sheets("Sheet2").Select
Cells(((i - 1) * 4) + 1, 1).Select
ActiveSheet.Paste
Next i
End Sub
This is what I have so far, but it is not working.
Option Explicit
Sub Copy_Paste()
Dim i As Integer
For i = 1 To 100
Dim ws1 As Worksheet, rng As Range, act As Range
Set ws1 = Worksheets("Data")
Set rng = ActiveSheet.Range("A2,B2,C2,D2,E2")
Set act = ActiveCell.Range(Cells(i, 1), Cells(i, 2))
Selection.Copy
Dim ws2 As Worksheet, rng2 As Range
Set ws2 = Worksheets("Calculate")
Set rng2 = Cells(((i - 1) * 4) + 1, 1)
ActiveSheet.Paste
Next i
End Sub
I used this type of operation in one of my vba codes:
'do copy from reference "Answers_Source" worksheet
wb.Sheets("Answers_Source").Range("h1:z160").Copy
'now paste the formulas into the student exam workbook
wb2.Sheets("Answers").Range("h1:z160").Paste
So you can edit that to your situation.
you could use Offset() property of Range object
Sub Copy_Paste()
Dim i As Long
For i = 1 To 100
Sheets("Sheet1").Range("A2,B2").Offset(i - 1).Copy Destination:=Sheets("Sheet2").Range("A1:B1").Offset((i - 1) * 4)
Next
End Sub
while if you only need paste values, then it's quicker:
Sub Copy_Paste_Values()
Dim i As Long
For i = 1 To 100
Sheets("Sheet2").Range("A1:B1").Offset((i - 1) * 4).Value = Sheets("Sheet1").Range("A2,B2").Offset(i - 1).Value
Next
End Sub
You know you can just say something like "Range x values = Range y values":
ws2.Range("A1:B4").Value = ws1.Range("A1:B4").Value
If you can define your ranges using Range(Cells(1,1), Cells(4,2)) then I'm pretty sure you can do everything you want in one line
I have edited this question from initial posting since I realized that no macro will activate the Worksheet_change function.
I am using a UserForm to create a macro to edit a cell. Then I want the Worksheet to take the value from one cell and create values in other cells. This works manually, but not in via macro!
From the UserForm:
Sub WriteOperatingFunds(dates, description, money)
Dim ws2 As Worksheet
Set ws2 = ThisWorkbook.Worksheets("OperatingFunds")
'find first empty row in database
irow = ws2.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
ws2.Cells(irow, 1).value = dates
ws2.Cells(irow, 2).value = description
ws2.Cells(irow, 3).value = money
End Sub
And from the worksheet:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim change As String
Dim chngRow As Long
Dim IncRow As Long
Dim ExpRow As Long
Dim TotRow As Long
Dim Income As Long
Dim Expense As Long
Dim Total As Long
Set ws = ThisWorkbook.Worksheets("OperatingFunds")
TotRow = ws.Cells(ws.Rows.Count, 5).End(xlUp).Row 'finds bottom of 'Total' Column
'looks for target in range
If Not Application.Intersect(Target, ws.Range("C3", ws.Cells(TotRow + 1, 4))) Is Nothing Then
change = Target.Address(False, False)
chngRow = ws.Range(change).Row
'Get the last rows of range columns
IncRow = ws.Range("C" & ws.Rows.Count).End(xlUp).Row
ExpRow = ws.Range("D" & ws.Rows.Count).End(xlUp).Row
Application.EnableEvents = False 'to prevent endless loop & does not record changes by macro
'if Total column is empty
If ws.Cells(chngRow, 5) = "" Then
Income = Application.WorksheetFunction.Sum(ws.Range("C3", ws.Cells(TotRow + 1, 3)))
Expense = Application.WorksheetFunction.Sum(ws.Range("D3", ws.Cells(TotRow + 1, 4)))
Total = Income + Expense
ws.Cells(chngRow, 5) = Total
'if total column is not empty (i.e. needs to be rewritten)
ElseIf ws.Cells(chngRow, 5) <> "" Then
Income = Application.WorksheetFunction.Sum(ws.Range("C3", ws.Cells(chngRow, 3)))
Expense = Application.WorksheetFunction.Sum(ws.Range("D3", ws.Cells(chngRow, 4)))
Total = Income + Expense
ws.Cells(chngRow, 5) = Total
End If
Else
MsgBox "Else is thrown."
Exit Sub
End If
Application.EnableEvents = True 'so that future changes can be read
End Sub
I don't want to be pretentious to answer my own question, but my friend helped me find the solution, and maybe this will help others with a similar problem.
The key factor is that I'm using a button on UserForm to write data to the cell. It's not actually "changing" the cell when I write "Cells(#,#) = value". In my code, I needed to turn the Sub public and then
Call ThisWorkbook.Worksheets("worksheetname").Worksheet_Change(Target.address)
This made everything work!
His example to help me: https://bytes.com/topic/access/answers/767919-trigger-click-event-button-another-form
I have a listbox on sheet1 with a list of sheetnames. When somebody double clicks on a name in the list, the code is supposed to activate that sheet, select some data and create a graph out of it.
The code is fine, right up until I ask it to define a range on the other sheet. I've had a number of different error messages and as best I can tell, the code is simply refusing to do anything that is not on sheet1. If somebody could explain why, that would be brilliant.
Code: the listbox is called Stocklist
Option Explicit
Sub StockList_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Call stockgraph
End Sub
Private Sub stockgraph()
Application.ScreenUpdating = False
Dim stockrange As Range
Dim daterange As Range
Dim security_name As String
Dim finalrow As Integer
Dim stockarray() As Double
Dim datearray() As String
Dim cell As Range
security_name = Empty
security_name = StockList.Value
If security_name = Empty Then MsgBox ("something's gone wrong, excel doesn't recognise that value") ' DEBUG
Worksheets(security_name).Activate ' --> this bit works fine
finalrow = ActiveSheet.Cells(1, 1).End(xlDown).row ' --> as does this
Set stockrange = Sheets(security_name).Range(Cells(2, 3), Cells(finalrow, 3))
' --> This gives a 1004 error, so does using activesheet
' --> if I don't reference a sheet, despite it not being the activesheet, the ranges are defined on sheet1
' --> and yet, the code was perfectly fine defining finalrow
Set daterange = Sheets(security_name).Range(Cells(2, 1), Cells(finalrow, 1))
ReDim stockarray(1 To finalrow - 1) As Double ' row 1 is a header so 2 to finalrow = 1 to finalrow-1
ReDim datearray(1 To finalrow - 1) As String
For Each cell In stockrange
stockarray(cell.row - 1) = cell.Value
Next cell
For Each cell In daterange
datearray(cell.row - 1) = cell.text
Next cell
Sheets("Top 10 holdings").Activate
' Create graph
Dim c As Chart
Dim s1 As Series
ActiveSheet.Cells(50, 50) = stockarray
ActiveSheet.Shapes.AddChart.Select
Set c = ActiveChart
Set s1 = c.SeriesCollection(1)
c.ChartType = xlLine
s1.Values = stockarray
Application.ScreenUpdating = True
End Sub
You cannot construct a cell range reference in that manner without fully qualifying the internal cell references used as demarcation points.
With Sheets(security_name)
finalrow = .Cells(1, 1).End(xlDown).row
Set stockrange = .Range(.Cells(2, 3), .Cells(finalrow, 3))
Set daterange = .Range(.Cells(2, 1), .Cells(finalrow, 1))
End With