I would like to change the width of the shape in this Excel in the attached picture. The size would be determined by the last column that contains data, in this case column E.
I have added the following code:
Sub UsedRange_Example_Column()
Dim LastColumn As Long
With ActiveSheet.UsedRange
LastColumn = .Columns(.Columns.Count).Column
End With
iCol = 0
For i = 3 To LastColumn
iCol = ActiveSheet.Cells(1, i).ColumnWidth + iCol
Next i
ActiveSheet.Shapes("Shape 37").Width = (iCol) * 5.72
End Sub
However, I am unable to determine the multiplier which I should use to change the size cause 5.72 is not giving me the correct results. Please note that column B is 1" in size.
Assuming your shape starts in col B, perhaps something like this. I have not specified the Top of the shape.
Sub UsedRange_Example_Column()
Dim LastColumn As Long
With ActiveSheet.UsedRange
LastColumn = .Columns(.Columns.Count).Column
End With
With ActiveSheet.Shapes("Shape 37")
.Left = Range("B1").Left
.Width = Range("B1").Resize(, LastColumn - 1).Width
End With
End Sub
You can set it to the width of your range in question:
Sub UsedRange_Example_Column()
Dim dataRng As Range, ws As Worksheet
Set ws = ThisWorkbook.Worksheets(1)
Set dataRng = ws.UsedRange
With ws.Shapes("Shape 37")
.Left = dataRng.Left
.Width = dataRng.Width
End With
End Sub
You should get out of the habit of using ActiveSheet whenever possible (most of the time it is). Always declare your worksheets as this can avoid many debugging nightmares.
Related
I have multiple cells ("positions") that require particular interior colors and values.
Each of these cells is associated with its own corresponding cell in another worksheet.
At the moment I have about 35 of these positions, but I may have 150 in the future, so adding these manually would be tedious! This is the code I have at the moment:
Dim FirstSheet As Worksheet
Dim Secondsheet As Worksheet
Dim position1 As Range
Dim position2 As Range
Dim position3 As Range
Dim lnCol As Long
Set FirstSheet As ThisWorkbook.Worksheets("FirstSheet")
Set SecondSheet As ThisWorkbook.Worksheets("SecondSheet")
Set position1 = Firstsheet.Range("G11")
Set position2 = Firstsheet.Range("F11")
Set Position3 = Firstsheet.Range("E11")
lnCol = 'this is a column number which is found earlier in the sub.
position1.Interior.Color = SecondSheet.Cells(8, lnCol).Interior.Color
position2.Interior.Color = SecondSheet.Cells(9, lnCol).Interior.Color
position3.Interior.Color = SecondSheet.Cells(10, lnCol).Interior.Color
position1.Offset(2, 0).Value = SecondSheet.Cells(8, lnCol).Value
position2.Offset(2, 0).Value = SecondSheet.Cells(9, lnCol).Value
position3.Offset(2, 0).Value = SecondSheet.Cells(10, lnCol).Value
Ideally, I would like a loop that would use two arrays that change at the same time, but I have no idea how to make it work! This is an example of what I would like to see:
For Each PositionVar In Array(position1, position2, position3)
PositionVar.Interior.Color = dynamicvariable.Interior.Color
PositionVar.Offset(2,0).Value = dynamicvariable.Value
Next PositionVar
Any help would be greatly appreciated!
Why dont you use two loops stacked together to solve this? For example:
for each rng in Array(Range1, Range2, Range3)
for each position in rng
'Do whatever you like with this Range
next position
next rng
You could use:
Option Explicit
Sub test()
Dim i As Long, y As Long, LastColumn As Long, Counter As Long, lnCol As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Counter = 8
lnCol = 3 'Change value
With ThisWorkbook
'Set the sheet with positions
Set ws1 = .Worksheets("Sheet1")
'Set the second sheet
Set ws2 = .Worksheets("Sheet2")
End With
With ws1
'Find the LastColumn of row 11
LastColumn = .Cells(11, .Columns.Count).End(xlToLeft).Column
'Loop from the last column until column 5th
For i = LastColumn To 5 Step -1
With .Cells(11, i)
.Interior.Color = ws2.Cells(Counter, lnCol).Interior.Color
.Offset(2, 0).Value = ws2.Cells(Counter, lnCol).Value
End With
Counter = Counter + 1
Next i
End With
End Sub
NOTE
The limitation of using Last column is that if there is no values in row 11 you should use a variable instead of last column referring to the total value of column you want
Managed to find an answer by using arrays and a control variable. You just need to ensure that the corresponding variables are in the same order!. Hope this helps others.
Dim PositionArray As Variant
Dim SecondSheetArray As Variant
Dim i As Variant
PositionArray = Array(position1, position2, position3)
SecondSheetArray = Array(SecondSheet1, SecondSheet2, SecondSheet3)
For i = 0 To UBound(PositionArray)
PositionArray(i).Interior.Color = OverviewArray(i).Interior.Color
PositionArray(i).Offset(2, 0).Value = OverviewArray(i).Value
Next i
I'm trying to get all my filtered data in one range variable but it doesn't work.
When the visible datas are continuous (rows 25 to 200), i've no problem but when the visible datas are discontinuous (rows 25 to 27, then 43 to 47, then 60 to 92) it only get the first range (rows 25 to 27)
Here is my code :
datas = dataSheet.Range("A2:L" & dataSheet.
[A65000].End(xlUp).Row).SpecialCells(xlCellTypeVisible).Value
Do you have any tip ?
Thank you for your answer.
Louis
It sounds like you're trying to populate an array variable named datas, which is successful if your range is continuous, but only gets the first section when discontinuous. And what you're looking for is to populate the array with all of the data from the discontinuous range.
That is possible, and there are two approaches. The first is to copy the discontinuous range and paste it into a temp worksheet. The pasted range will be continuous and then you can load it into the array normally as shown in your original code. The second is to populate the array directly, but you'll have to loop through each visible cell to do this.
Method 1 (use temp worksheet):
Sub tgrTempWS()
Dim dataSheet As Worksheet
Dim tempSheet As Worksheet
Dim rData As Range
Dim datas As Variant
Set dataSheet = ActiveWorkbook.Sheets("Sheet1")
On Error Resume Next
Set rData = dataSheet.Range("A2:L" & dataSheet.[A65000].End(xlUp).Row).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rData Is Nothing Then Exit Sub 'No data
Set tempSheet = dataSheet.Parent.Sheets.Add
rData.Copy tempSheet.Range("A1")
datas = tempSheet.Range("A1").CurrentRegion.Value
Application.DisplayAlerts = False
tempSheet.Delete
Application.DisplayAlerts = True
'do stuff with your datas array variable here
End Sub
Method 2 (loop through visible cells):
Sub tgrLoop()
Dim dataSheet As Worksheet
Dim rData As Range
Dim rCell As Range
Dim datas As Variant
Dim lRow As Long, lCol As Long
Dim i As Long, j As Long
Set dataSheet = ActiveWorkbook.Sheets("Sheet1")
On Error Resume Next
Set rData = dataSheet.Range("A2:L" & dataSheet.[A65000].End(xlUp).Row).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rData Is Nothing Then Exit Sub 'No data
ReDim datas(1 To Intersect(rData, rData.Areas(1).Resize(, 1).EntireColumn).Cells.Count, 1 To rData.Columns.Count)
For Each rCell In rData.Cells
If lRow = 0 Then
lRow = rCell.Row
i = 1
ElseIf rCell.Row > lRow Then
i = i + 1
lRow = rCell.Row
End If
If lCol = 0 Or rCell.Column < lCol Then
lCol = rCell.Column
j = 1
ElseIf rCell.Column > lCol Then
j = j + 1
lCol = rCell.Column
End If
datas(i, j) = rCell.Value
Next rCell
'do stuff with your datas array variable here
End Sub
From MSDN about Range Object : "Represents a cell, a row, a column, a selection of cells containing one or more contiguous blocks of cells, or a 3-D range."
That's why you only get the first range. Have a look at this page to refer to multiple ranges.
An over-simplified description of my problem is illustrated in the figures below. I want to transform sparse data from a column in the Page1 worksheet to dense and then load it in a dense range in the Page2 worksheet.
My solution so far is that in the following code snippet. I would like to know if there is a more efficient alternative to achieve this goal, namely without a for loop or at least without the j variable.
Sub CopyFromMultipleRanges()
With Worksheets("Page1")
.Range("A1:A5").Value = 1
.Range("A8:A10").Value = 2
Dim c_cell As Range
Dim j As Long
j = 1
For Each c_cell In .Range("A1:A5,A8:A10")
Worksheets("Page2").Range("A" & j).Value = c_cell.Value
j = j + 1
Next
End With
Worksheets("Page2").Activate
End Sub
Initial column where data is sparse.
Final dense data column.
You can do this if you want to remove the blanks on the same sheet. If not just copy the data to a new sheet and then run this on that range
Sub Delete_Blank_Rows()
On Error Resume Next
Range("A1:A10").Select
Selection.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Here's how I would do it:
'create a collection to store the data
Dim bin As New Collection
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim size As Long
Dim i As Long
Dim v As Variant
'set worksheet references
Set ws1 = Excel.Application.ThisWorkbook.Worksheets("Page1")
Set ws2 = Excel.Application.ThisWorkbook.Worksheets("Page2")
With ws1
size = .UsedRange.Rows.Count
'loop through the range to pick up the data from non-empty cells
For i = 1 To size
'if the cell is not empty, then add the value to the collection
If Not IsEmpty(.Cells(i, 1).Value) Then
bin.Add .Cells(i, 1).Value
End If
Next
'loop through the bin contents
i = 1
For Each v In bin
ws2.Cells(i, 1).Value = v
i = i + 1
Next
End With
Hope it helps!
Update:
I tested this code and it works:
Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Excel.Application.ThisWorkbook.Worksheets(1)
Set ws2 = Excel.Application.ThisWorkbook.Worksheets(2)
ws1.Range("A:A").SpecialCells(xlCellTypeConstants).Copy ws2.Range("A:A")
End Sub
you can read more about Range.SpecialCells here. learn something new everyday!
This assumes that you are considering the all rows with the lower and upper row limits of the ranges given ie. that "A1:A5" and "A8:A10" is indeed "A1:A10".
Option Explicit
Public Sub CopyFromMultipleRanges()
Dim rng As Range: Set rng = ThisWorkbook.Worksheets("Page1").Range("A1:A10")
Application.ScreenUpdating = False
If Application.WorksheetFunction.CountBlank(rng) = rng.Count Then Exit Sub
With rng
.AutoFilter
.AutoFilter 1, "<>"
.SpecialCells(xlCellTypeVisible).Copy Worksheets("Page2").Range("A1")
.AutoFilter
Application.ScreenUpdating = True
End With
End Sub
I have a macro which changes column width and row height of all the worksheets in my excel workbook, however, this macro is not making the changes in the hidden rows and column.
Please suggest how should I modify my code so that it should change the column width and row height of hidden rows and columns and keep them hidden?
Sub rowcolactivesheetb()
Dim exworkb As Workbook
Dim xlwksht As Worksheet
Dim lastrow1 As Long
Dim lastcolumn1 As Long
Dim firstrowDB As Long
With ActiveSheet
lastrow1 = .Cells(Rows.Count, "A").End(xlUp).Row
lastcolumn1 = .Cells(1, Columns.Count).End(xlToLeft).Column
.Range(.Cells(1, 1), .Cells(lastrow1, lastcolumn1)).Select
With Selection.SpecialCells(xlCellTypeVisible)
.ColumnWidth = 10.2
.RowHeight = 9.4
End With
End With
End Sub
Edit
I have implemented Wolfie's method below, but am now getting
Run-time error 91, Object variable or With block variable not set.
on this line:
' Z is a number, my loop variable for looping over each sheet
rng = ActiveWorkbook.Sheets(Z).Range(Sheets(Z).Cells(1, 3), Sheets(Z).Cells(lastrow1, lastcolumn1))
The below code is fairly straight-forward, and commented for further details. Steps:
Loop through rows and columns in the used range, note which ones are hidden.
Unhide everything and resize
Loop back through rows and columns, hiding those which were hidden before
Code:
Sub rowcolactivesheetb()
' Resizes all rows and columns, including those which are hidden.
' At the end, hidden rows and columns remain hidden.
Dim n As Long
Dim hiddencols() As Long
Dim hiddenrows() As Long
Dim rng As Range
Application.ScreenUpdating = False
With ThisWorkbook.ActiveSheet
' Set up range variable and true/false hidden arrays
' We don't need to find last row/col, just used UsedRange
Set rng = .UsedRange
ReDim hiddencols(rng.Columns.Count)
ReDim hiddenrows(rng.Rows.Count)
' Get hidden/visible status of each row and column
For n = 0 To UBound(hiddencols)
hiddencols(n) = rng.Columns(n + 1).Hidden
Next n
For n = 0 To UBound(hiddenrows)
hiddenrows(n) = rng.Rows(n + 1).Hidden
Next n
' Unhide all
rng.EntireColumn.Hidden = False
rng.EntireRow.Hidden = False
' resize all
rng.ColumnWidth = 10.2
rng.RowHeight = 9.4
' Re-hide rows/cols
For n = 0 To UBound(hiddencols)
rng.Columns(n + 1).Hidden = hiddencols(n)
Next n
For n = 0 To UBound(hiddenrows)
rng.Rows(n + 1).Hidden = hiddenrows(n)
Next n
End With
Application.ScreenUpdating = True
End Sub
Lastly a note on With, you should not start a second With block unless it is for an object within the first one. But really you could have ditched the (undesirable) Select using that fact anyway...
With ActiveSheet
lastrow1 = .Cells(Rows.Count, "A").End(xlUp).Row
lastcolumn1 = .Cells(1, Columns.Count).End(xlToLeft).Column
With .Range(.Cells(1, 1), .Cells(lastrow1, lastcolumn1)).SpecialCells(xlCellTypeVisible)
.ColumnWidth = 10.2
.RowHeight = 9.4
End With
End With
Edit:
With respect to your follow up error, you must use the Set command when assigning a Range object to a variable. So your code should be
Set rng = ActiveWorkbook.Range("...
You don't have to use Set for fundamental variable types (Strings, Integers, etc)
I have a code that change the rows height and column width of all the sheets in the workbook from row 1 and column B.
My problem is that its making all my hidden columns and rows also visible.
Please suggest as to how I shud modify the code so that it can change the column width and row height but should be kept them hidden.
Sub rowcolallsheetb()
Dim exworkb As Workbook
Dim xlwksht As Worksheet
Dim lastrow1 As Long
Dim lastcolumn1 As Long
Dim firstrowDB As Long
Dim Z As Integer
Dim ShtNames() As String
ReDim ShtNames(1 To ActiveWorkbook.Sheets.Count)
For Z = 1 To Sheets.Count
ShtNames(Z) = Sheets(Z).Name
Sheets(Z).Select
lastrow1 = Sheets(Z).Cells(Rows.Count, "A").End(xlUp).Row
lastcolumn1 = Sheets(Z).Cells(1, Columns.Count).End(xlToLeft).Column
ActiveWorkbook.Sheets(Z).Range(Sheets(Z).Cells(1, 2), Sheets(Z).Cells(lastrow1, lastcolumn1)).Select
Selection.Cells.RowHeight = 9.4
Selection.Cells.ColumnWidth = 11.2
Next Z
End Sub
Use SpecialCells(xlCellTypeVisible) to exclude the hidden cells from your action:
With ActiveWorkbook.Sheets(Z).Range("B1", Sheets(Z).Cells(lastrow1, lastcolumn1)) _
.SpecialCells(xlCellTypeVisible)
' ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
.ColumnWidth = 11.2
.RowHeight = 9.4
End With
You could also use
'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
With Selection.SpecialCells(xlCellTypeVisible)
.ColumnWidth = 11.2
.RowHeight = 9.4
End With
But it's always recommended to avoid using the Select stuff in VBA.