Hi I'm trying to create macro that will collect data from excell table. I create strings with similar names and ended by number. Please is there a way to loop over this strings ? This Code is not working, but will explain what I want to do.
Sub vzor()
Dim i As Integer
Dim input1, input2, input3, input4, input5, input6, input7, _
input8, input9, input10, input11, input12, input13, input14, _
input15, input16, input17, input18, input19, input20, input21, _
input22, input23, input24, input25, input26, input27, input28, _
input29, input30, input31, input32, input33, input34, input35, _
input36, input37, input38, input39, input40, input41, input42, _
input43, input44, input45, input46, input47, input48, input49, _
input50, input51, input52, input53, input54, input55, input56, _
input57, input58, input59, input60, input61, input62, input63, _
input64, input65, input66, input67 As String
For i = 2 To 67
If Range("B" & i).Value = "" Then
MsgBox "Please fill all required data (The cells with red fill)", vbOKOnly, "Missing data"
Range("B" & i).Select
Else
input & i = Range("B" & i).Value
End If
Next
This seems to be a perfect example for a dictionary
Option Explicit
Dim wb As Workbook, ws As Worksheet
Dim inputdict As Variant
Dim i As Long
Set inputdict = CreateObject("Scripting.Dictionary")
Set wb = ThisWorkbook 'Change if necessary
Set ws = wb.Sheets(1) 'Change if necessary
For i = 1 To 67
If ws.Cells(i, "B").Value = vbNullString Then
MsgBox "Please fill all required data (The cells with red fill)", vbOKOnly, "Missing data"
ws.Cells(i, "B").Select
Else
inputdict.Add i, ws.Cells(i, "B").Value
End If
Next i
This creates a dictionary (inputdict). The keys for this dictionary are integers defined by i ranging from 1 to 67. The values are the values in the cells as you specified in your code already.
Related
I know this is a duplicate, but 30 minutes of googling couldn't find an answer.
In Excel, at times extra cells or rows can become activated - usually by going too far down on a worksheet, "Activating" all 1M + rows. This has a negative impact on performance, both in memory, file size, and usability.
I previously saw a post of how you can "re-size" what Excel thinks is an activated cell, but I can't find it.
How do I resize (Using VBA) an Excel Spreadsheet's activated cells, preferably using VBA? (You can nuke and re-make the sheet... but I'd prefer to avoid that)
To be clear, I'm refering to the set of cells Excel thinks it needs to store and remember. For example, if you go to cell A1048576, put a period in the cell, hit enter, then delete it and scroll up, Excel "Remembers" that all 1048576 rows are now activated, and will continue to keep them around. You can tell this is happening partially due to the scroll bar.
A third way - I'd like to re-define where on the spreadsheet Excel takes me when I hit Ctr+End - it brings you to what it currently thinks is the last row and the last column, but it's incorrect, and I'd like to remind Excel what the correct boundaries are.
you are talking about UsedRange
to reduce it, you have to
1) clear everything from range (including formating; you can just delete rows/columns)
2) save document
In order to reset the last cell in an worksheet using VBA, you can use the following code that will clear the excess formatting:
Sub ClearExcessRowsAndColumns()
Dim ar As Range, r As Long, c As Long, tr As Long, tc As Long, x As Range
Dim wksWks As Worksheet, ur As Range, arCount As Integer, i As Integer
Dim blProtCont As Boolean, blProtScen As Boolean, blProtDO As Boolean
Dim shp As Shape
If ActiveWorkbook Is Nothing Then Exit Sub
On Error Resume Next
For Each wksWks In ActiveWindow.SelectedSheets 'Applies only to selected sheets (can be more than one)
Err.Clear
Set ur = Nothing
'Store worksheet protection settings and unprotect if protected.
blProtCont = wksWks.ProtectContents
blProtDO = wksWks.ProtectDrawingObjects
blProtScen = wksWks.ProtectScenarios
wksWks.Unprotect ""
If Err.Number = 1004 Then
Err.Clear
MsgBox "'" & wksWks.Name & _
"' is protected with a password and cannot be checked." _
, vbInformation
Else
Application.StatusBar = "Checking " & wksWks.Name & _
", Please Wait..."
r = 0
c = 0
'Determine if the sheet contains both formulas and constants
Set ur = Union(wksWks.UsedRange.SpecialCells(xlCellTypeConstants), _
wksWks.UsedRange.SpecialCells(xlCellTypeFormulas))
'If both fails, try constants only
If Err.Number = 1004 Then
Err.Clear
Set ur = wksWks.UsedRange.SpecialCells(xlCellTypeConstants)
End If
'If constants fails then set it to formulas
If Err.Number = 1004 Then
Err.Clear
Set ur = wksWks.UsedRange.SpecialCells(xlCellTypeFormulas)
End If
'If there is still an error then the worksheet is empty
If Err.Number <> 0 Then
Err.Clear
If wksWks.UsedRange.Address <> "$A$1" Then
wksWks.UsedRange.EntireRow.Hidden = False
wksWks.UsedRange.EntireColumn.Hidden = False
wksWks.UsedRange.EntireRow.RowHeight = _
IIf(wksWks.StandardHeight <> 12.75, 12.75, 13)
wksWks.UsedRange.EntireColumn.ColumnWidth = 10
wksWks.UsedRange.EntireRow.Clear
'Reset column width which can also _
cause the lastcell to be innacurate
wksWks.UsedRange.EntireColumn.ColumnWidth = _
wksWks.StandardWidth
'Reset row height which can also cause the _
lastcell to be innacurate
If wksWks.StandardHeight < 1 Then
wksWks.UsedRange.EntireRow.RowHeight = 12.75
Else
wksWks.UsedRange.EntireRow.RowHeight = _
wksWks.StandardHeight
End If
Else
Set ur = Nothing
End If
End If
'On Error GoTo 0
If Not ur Is Nothing Then
arCount = ur.Areas.Count
'determine the last column and row that contains data or formula
For Each ar In ur.Areas
i = i + 1
tr = ar.Range("A1").Row + ar.Rows.Count - 1
tc = ar.Range("A1").Column + ar.Columns.Count - 1
If tc > c Then c = tc
If tr > r Then r = tr
Next
'Determine the area covered by shapes
'so we don't remove shading behind shapes
For Each shp In wksWks.Shapes
tr = shp.BottomRightCell.Row
tc = shp.BottomRightCell.Column
If tc > c Then c = tc
If tr > r Then r = tr
Next
Application.StatusBar = "Clearing Excess Cells in " & _
wksWks.Name & ", Please Wait..."
If r < wksWks.Rows.Count And r < wksWks.Cells.SpecialCells(xlCellTypeLastCell).Row Then
Set ur = wksWks.Rows(r + 1 & ":" & wksWks.Cells.SpecialCells(xlCellTypeLastCell).Row)
ur.EntireRow.Hidden = False
ur.EntireRow.RowHeight = IIf(wksWks.StandardHeight <> 12.75, _
12.75, 13)
'Reset row height which can also cause the _
lastcell to be innacurate
If wksWks.StandardHeight < 1 Then
ur.RowHeight = 12.75
Else
ur.RowHeight = wksWks.StandardHeight
End If
Set x = ur.Dependents
If Err.Number = 0 Then
ur.Clear
Else
Err.Clear
ur.Delete
End If
End If
If c < wksWks.Columns.Count And c < wksWks.Cells.SpecialCells(xlCellTypeLastCell).Column Then
Set ur = wksWks.Range(wksWks.Cells(1, c + 1), _
wksWks.Cells(1, wksWks.Cells.SpecialCells(xlCellTypeLastCell).Column)).EntireColumn
ur.EntireColumn.Hidden = False
ur.ColumnWidth = 18
'Reset column width which can _
also cause the lastcell to be innacurate
ur.EntireColumn.ColumnWidth = _
wksWks.StandardWidth
Set x = ur.Dependents
If Err.Number = 0 Then
ur.Clear
Else
Err.Clear
ur.Delete
End If
End If
End If
End If
'Reset protection.
wksWks.Protect "", blProtDO, blProtCont, blProtScen
Err.Clear
Next
Application.StatusBar = False
MsgBox "'" & ActiveWorkbook.Name & _
"' has been cleared of excess formatting." & Chr(13) & _
"You must save the file to keep the changes.", vbInformation
End Sub
NOTE: This code was slightly adapted from the code provided in the XSFormatCleaner add-in made by AKeeler. It used to be available on CodePlex before the platform got discontinued (Archive).
I was tasked with creating a code that will check to see if internal hyperlinks in an excel spreadsheet worked. This code first changes the formulas that were on the spreadsheet and makes them actual hyperlinks (they were originally formulas linking the locations together). The problem that I have now is that I want to create hyperlinks ONLY if Column S has text. If it doesn't, I don't want the "E-COPY" text to be displayed. All of the text in Column S varies (not one line has the same characters), which is why I'm drawing a blank is to how I tell the program to only continue if it has any text, not anything specific. I am working with Excel 2016.
Also, I am doing this to 71935 and counting rows; is there a limit to how many it can go through? If so, what can I do about it?
Thank you!
Sub CreateHyperlinks()
Dim FN As Variant
Dim Path As Variant
Dim count As Variant
Sheets(1).Activate
count = WorksheetFunction.CountA(Sheets(1).Range("A:A"))
For i = 2 To count
If Range("AM" & i).Value = "Yes" And Columns("S") = Then
Range("E" & i).Value = ""
Path = Sheets(1).Range("R" & i).Value
FN = Sheets(1).Range("S" & i).Value
Sheets(1).Range("E" & i).Select
Selection.ClearFormats
Selection.Hyperlinks.Add Anchor:=Selection, Address:=Path & FN, TextToDisplay:="E-COPY"
Range("AM" & i).Value = " "
End If
Next i
End Sub
If you just need to check for any content in ColS then:
If Range("AM" & i).Value = "Yes" And Len(Range("S" & i).Value) > 0 Then
Few things:
'make a reference to the sheet you're working with
Dim ws As Worksheet
Dim wb As Workbook
Set wb = Excel.Application.ThisWorkbook
Set ws = wb.Worksheets(1)
'gets the absolute last row with data in it // ignores empty cells
count = ws.UsedRange.Rows.Count
personally, i hate working with named ranges, so i would suggest setting range references like so
what you wrote
Path = Sheets(1).Range("R" & i).Value
what i believe it should look like
Path = ws.Cells(i, 18).Value
if you want to test the type when working with variants, try this:
'tests the type associated with the variant. an 8 = string
If VarType(ws.Cells(i, 19).Value) = 8 Then
'do your thing
'tests if the value is null
ElseIf VarType(ws.Cells(i, 19).Value) = 0 Then
'do your other thing
here's a list of the vartype enumeration to help you out.
hope it helps!
I am currently working on a project that requires me to use values from a multicolumn list. I have single column listboxes within this userform that I want a value selected given the selected multicolumn list. As of now, I can get the single listboxes to get highlighted but for some odd reason, the values aren't being selected. I need to be able to pull these values if the user doesn't select another list value. I am new at posting in this forum but I have an excel file to demonstrate my problem but do not know how to post it on here.
Since I don't know how to upload the file here's what I've coded:
Private Sub ListBox1_AfterUpdate()
Me.ListBox2.Value = ListBox1.Column(1)
Me.ListBox3.Value = ListBox1.Column(2)
Me.ListBox4.Value = ListBox1.Column(3)
Me.ListBox5.Value = ListBox1.Column(4)
MsgBox ListBox2.Value & " = " ListBox3.Value & " = " ListBox4.Value & " = " ListBox5.Value ' Check values
End Sub
Private Sub UserForm_Initialize()
With ListBox1
.ColumnCount = 15
.RowSource = ActiveSheet.Range("A1:E10").Address
End With
With Sheets("Sheet2")
ListBox2.RowSource = "'" & .Name & "'!" & .Range("Variable1").Address
ListBox3.RowSource = "'" & .Name & "'!" & .Range("Variable2").Address
ListBox4.RowSource = "'" & .Name & "'!" & .Range("Variable3").Address
ListBox5.RowSource = "'" & .Name & "'!" & .Range("Variable4").Address
End With
End Sub
And just so you guys know, the values in the specific columns are limited to the variable ranges. If anyone can help out, it could be truly appreciated. Thanks!
List boxes have the Selected property which is a boolean collection of list items numbered from 0 to ListCount-1.To pre-select the 3rd item in ListBox5 you would use code like ListBox5.Selected(3)=True. Use False to unselect it.
You aren't quite going about it in a way that is easy to correct. Therefore I have written a little code for you to play with. Please create a userform with one ListBox and call it ListBox2 Paste the code below into the UserForm's code sheet.
Option Explicit
Private Sub UserForm_Click()
Static i As Integer
With ListBox2
.Selected(i) = True
MsgBox "ListIndex = " & .ListIndex & vbCr & _
"Value = " & .Value & vbCr & _
"Column(3) = " & .Column(3)
End With
i = i + 1
If i > 6 Then i = 0
End Sub
Private Sub UserForm_Initialize()
Dim Rng(2 To 5) As Range
Dim Id As Integer
With ActiveSheet
Set Rng(2) = .Range(.Cells(3, 3), .Cells(8, 7))
Set Rng(3) = .Range(.Cells(9, 3), .Cells(18, 7))
Set Rng(4) = .Range(.Cells(19, 3), .Cells(28, 7))
Set Rng(5) = .Range(.Cells(29, 3), .Cells(38, 7))
End With
For Id = LBound(Rng) To UBound(Rng)
SetListBox Id, Rng
Exit For ' for testing: exit after doing the first ListBox
Next Id
End Sub
Private Sub SetListBox(Id As Integer, Rng() As Range)
Dim Wdth As String
Dim i As Integer
Wdth = "60 pt"
For i = 2 To Rng(Id).Columns.Count
Wdth = Wdth & "; 0pt"
Next i
With Me.Controls("ListBox" & CStr(Id))
.RowSource = Rng(Id).Address(External:=True)
.ColumnCount = Rng(Id).Columns.Count
.ColumnWidths = Wdth
End With
End Sub
Run the code on F5 and click anywhere on the form - repeatedly if you like.
The basic arrangement is that there is a list with 5 columns. The number of columns is equal to the number of columns in the source range. The first column is 60 pts wide, the others hidden. The idea is that the user selects an item from the visible column and the other ListBoxes are set according to the values in the hidden columns. I didn't set that up but ListBox2.Column(3) will return the value from column 3 of the selected item.
I hope you have all the syntax that you need to make your idea work. It isn't arranged quite the way you want, but I believe it is all there. Good luck.
this is my first time using the site, so forgive me for any inept explaining. I have a working macro to hide/unhide rows based on content of the rows, I just want it to be faster. Using a check box, when the box is checked, all rows with an "x" in column D get unhidden, those without an "x" get hidden. Same thing happens when it is unchecked, except it references column C, not D.
Right now, this code works. It's just a little slower than I'd like, since I'm sharing this with a bunch of people. Any ideas for how to speed it up? I'm pretty darn new to VB (the internet is astoundingly wise and a good teacher), but that doesn't matter. I already improved the code - before it selected each row, then referenced the column, and it was awful. Any ideas to speed it up (preferably without moving the screen) would be great.
Thanks so much folks,
DS
Sub NewLuxCheck()
Dim x As Integer
NumRows = Range("A42", "A398").Rows.Count
Range("A42").Select
If ActiveSheet.Shapes("checkbox2").OLEFormat.Object.Value = 1 Then
For x = 42 To NumRows + 41 Step 1
If Worksheets("Base").Range("D" & x).Value = "x" Then
Worksheets("Base").Range(x & ":" & x).EntireRow.Hidden = False
Else
Worksheets("Base").Range(x & ":" & x).EntireRow.Hidden = True
End If
Next
Else
For x = 42 To NumRows + 41 Step 1
If Worksheets("Base").Range("C" & x).Value = "x" Then
Worksheets("Base").Range(x & ":" & x).EntireRow.Hidden = False
Else
Worksheets("Base").Range(x & ":" & x).EntireRow.Hidden = True
End If
Next
End If
MsgBox ("Done")
End Sub
You could use array formula and let Excel to return array with row-numbers where 'x' value occures. It will be quicker but you'll have to reorganise your code and create separate functions etc.
Here example where array formula finds rows whre in column 'D' the cell has value 'x'. Then string of this row numbers is created in form of "A1,A5,A10" ...means 'x' was found in rows 1,5,10. And finally Range(rowsJoind).EntireRow.Hidden is used for all the rows to be hidden/un-hidden in one step.
For rows with value different then 'x' you'll have to use formula like '=IF({0}<>""x"", ROW({0}), -1)'.
Sub test()
Dim inputRange As Range
Dim lastRow As Long
Dim myFormula As String
Dim rowsJoined As String, i As Long
Dim result As Variant
With Worksheets("Base")
lastRow = .Range("D" & .Rows.Count).End(xlUp).Row
Set inputRange = .Columns("D").Resize(lastRow)
Application.ReferenceStyle = xlR1C1
myFormula = "=IF({0}=""x"", ROW({0}), -1)"
myFormula = VBA.Strings.Replace(myFormula, "{0}", inputRange.Address(ReferenceStyle:=xlR1C1))
result = Application.Evaluate(myFormula)
result = Application.Transpose(result)
Application.ReferenceStyle = xlA1
For i = LBound(result) To UBound(result)
If (result(i) > -1) Then
rowsJoined = rowsJoined & "A" & result(i) & IIf(i < UBound(result), ",", "")
End If
Next i
.Range(rowsJoined).EntireRow.Hidden = False
End With
End Sub
I am new to Excel macros..
Can anyone tell me what this macro does?
Sub People_Add_Document()
prow = ActiveCell.row
num = Cells(prow, 1).Value
wshet = ActiveSheet.Name
If (Val(num) > 0) _
And (Cells(4, 1).Value = "#") _
And (wsheet = People_wsheet) _
Then
people_select_link_to_Document process_wbook_path, prow
End If
End Sub
Sub people_select_link_to_Document(process_wbook_path, prow)
If Len(Cells(prow, DocumentFile).Value) = 0 Then
Fname = Application.GetOpenFilename("Document Files (*.doc;*.pdf),*.doc;*.pdf", 1, "Select the Document file..")
If Fname <> False Then
Cells(prow, DocumentFile).Value = Fname 'global path
End If
End If
End Sub
Get the row number of the active cell:
prow = ActiveCell.row
Get the value in column 1 of that row:
num = Cells(prow, 1).Value
Read the name of the active worksheet (there is an error here, should read wsheet rather than wshet):
wshet = ActiveSheet.Name
Test if num is greater than 0, and the cell A4 contains "#" and the active worksheet is equal to a variable or constant called People_wsheet. And if so, a subroutine called people_select_link_to_Document is called with parameters process_wbook_path and prow
If (Val(num) > 0) _
And (Cells(4, 1).Value = "#") _
And (wsheet = People_wsheet) _
Then
people_select_link_to_Document process_wbook_path, prow
End If
Now, that subroutine first of all checks to see if the DocumentFile column of the active row is empty. Actually it's a rather lame way to test emptyness, but it will probably do.
If Len(Cells(prow, DocumentFile).Value) = 0 Then
And if it is empty then we show a file dialog to obtain a file name:
Fname = Application.GetOpenFilename("Document Files (*.doc;*.pdf),*.doc;*.pdf", 1, "Select the Document file..")
If a filename has been selected (i.e. the dialog is not cancelled) then we save that file name in the DocumentFile column of the active row for future reference:
If Fname <> False Then
Cells(prow, DocumentFile).Value = Fname 'global path
End If
And that's it!