I'm trying to write a macro that allows a user to enter a new banknote serial number. The macro requires 3 inputs (currency, denomination and serial number). I'm a beginner to VBA, but the code I tried to write is below. Can anyone point out where I went wrong, or what needs to be changed to make it work? Thanks!
Sub TestSub()
Dim Note_Serial As Variant
Dim Note_Currency As Variant
Dim Note_Denomination As Variant
'Defining 3 inputs
Note_Currency = InputBox("Enter Currency (in 3 letter form):")
Note_Denomination = InputBox("Enter Note Denomination (with $ sign):")
Note_Serial = InputBox("Enter Serial Number:")
'Getting 3 inputs
Dim Currency_Cell As Range
Dim Denomination_Cell As Range
Dim Serial_Cell As Range
'Defining cells to write inputs
Currency_Cell = (D3)
Denomination_Cell = (E3)
Serial_Cell = (F3)
'Starting cells
Currency_Cell = Note_Currency
Denomination_Cell = Note_Denomination
Serial_Cell = Note_Serial
'Writing inputs to spreadsheet
Currency_Cell.Offset (1)
Denomination_Cell.Offset (1)
Serial_Cell.Offset (1)
'Moving all cells down 1 place
End Sub
Instead of writing Currency_Cell = (D3), you want to write Set Currency_Cell = Range("D3") (Assuming that you don't switch the active Worksheet).
EDIT: To prevent overwriting previously entered data, use instead:
Set Currency_Cell = Cells(Rows.Count, Range("D3").Column).End(xlUp).Offset(1, 0)
This will select the first empty Cell in Column D.
To move the cell reference, you have to also use the Set keyword, and give the offset in rows and columns:
Set Currency_Cell = Currency_Cell.Offset (1, 0)
Related
I have a data of some binary numbers in few range of cells, from A2 to A8, B2 to B8, and so on, till G column.
Now, I want to check the largest binary number from the above Rows and paste it to the cell, two row below the last used range. (i.e., Largest binary number from Row A to be paste in A10, and so on).
I am not finding any function which can find the value of binary numbers, and the code which I ran finds out the max number considering those as natural numbers.
Your help will be appreciated.
Thank You!
Okay first i made a function that converts binary to decimal and stored in a module. (You can store it wherever you want) This function handles any size binary
Function BinToDecConverter(BinaryString As String) As Variant
Dim i As Integer
For i = 0 To Len(BinaryString) - 1
BinToDecConverter = CDec(BinToDecConverter) + Val(Mid(BinaryString, Len(BinaryString) - i, 1)) * 2 ^ i
Next
End Function
Afterwards i made the sub that loops through all binarys on sheet1 (Might need to change this for your sheet)
Sub FindLargestBinary()
On Error Resume Next
Dim wb As Workbook
Dim ws As Worksheet
Set wb = Application.ThisWorkbook
Set ws = wb.Sheets("Sheet1")
Dim tempVal, tempRow As Integer
Dim iCoulmn, iRow As Integer
For iCoulmn = 1 To 7 'Run from A to G
tempRow = 2
tempVal = 0
For iRow = 2 To 8 'Run from row 2 to 8
If BinToDecConverter(ws.Cells(iRow, iCoulmn).Value) > tempVal Then tempVal = BinToDecConverter(ws.Cells(iRow, iCoulmn).Value): tempRow = iRow ' Check if current binary i higher then any previous
Next iRow
ws.Cells(iRow + 1, iCoulmn).Value = ws.Cells(tempRow, iCoulmn).Value 'Print highest binary
Next iCoulmn
End Sub
Hope this helps you out..
You can use the excel function Bin2Dec to change them into decimal
Function MaxBin(r as range)
Dim curmax as long
Dim s as range
For each s in r
If Application.WorksheetFunction.Bin2Dec(s.Text) > curmax Then curmax = Application.WorksheetFunction.Bin2Dec(s.Text)
Next s
MaxBin = curmax
End Function
Assuming your binary values are text strings this formula converts the values to numbers, finds the MAX and then converts back to a text string
=TEXT(MAX(A2:A8+0),"00000")
confirmed with CTRL+SHIFT+ENTER
or you can use this version which finds the max using AGGREGATE function and doesn't require "array entry"
=DEC2BIN(AGGREGATE(14,6,BIN2DEC(A2:A8+0),1))
I have 3 sheets, in sheet one I have a column "Register Codes" and I have extracted the unique codes in next column. Please check the below image.
Based on these unique codes, sub-codes are allocated in sheet 2. please check the below image.
Now what I am trying here is that in sheet 3 I need every "Register code" with the relevant "sub-code" which is allocated in sheet2 based on the "unique ID" given in Sheet1. please check the below image for expected output.
I have been using various combinations of formulas but could not get a proper solution. What is the best way to do it in VBA as I just started learning in this field.
Subject to a few conditions the following code will do what you want. Install it in a standard code module (by default "Module1", but you can name it as you like) in the workbook where you have your data.
Option Explicit
Enum Nws ' Worksheet navigation
NwsFirstDataRow = 2 ' presumed the same for all worksheets
NwsCode = 1 ' 1 = column A (change as required)
NwsSubCode ' No value means previous + 1
NwsNumer
End Enum
Sub NumerList()
' 05 Apr 2017
Dim Wb As Workbook ' all sheets are in the same workbook
Dim WsCodes As Worksheet ' Register codes
Dim WsNum As Worksheet ' Sub-code values
Dim WsOut As Worksheet ' Output worksheet
Dim RegName As String, RegCode As String
Dim Sp() As String
Dim Rs As Long ' Source row in WsNum
Dim Rt As Long ' Target row in WsOut
Dim R As Long, Rl As Long ' rows / Last row in WsCodes
Set Wb = ActiveWorkbook ' Make sure it is active!
Set WsCodes = Wb.Worksheets("Reg Codes") ' Change name to your liking
Set WsNum = Wb.Worksheets("Code Values") ' Change name to your liking
On Error Resume Next
Set WsOut = Wb.Worksheets("Output") ' Change name to your liking
If Err Then
Set WsOut = Wb.Worksheets.Add(After:=WsNum)
WsOut.Name = "Output" ' create the worksheet if it doesn't exist
End If
On Error GoTo 0
Rt = NwsFirstDataRow
With WsCodes
Rl = .Cells(.Rows.Count, NwsCode).End(xlUp).Row
For R = NwsFirstDataRow To Rl
RegName = .Cells(R, NwsCode).Value
Sp = Split(RegName, "-")
If UBound(Sp) > 1 Then ' must find at least 2 dashes
RegCode = Trim(Sp(1))
Else
RegCode = ""
End If
If Len(RegCode) Then
On Error Resume Next
Rs = WorksheetFunction.Match(RegCode, WsNum.Columns(NwsCode), 0)
If Err Then Rs = 0
On Error GoTo 0
If Rs Then
Do
WsOut.Cells(Rt, NwsCode).Value = RegName
WsOut.Cells(Rt, NwsSubCode).Value = WsNum.Cells(Rs, NwsSubCode).Value
WsOut.Cells(Rt, NwsNumer).Value = WsNum.Cells(Rs, NwsNumer).Value
Rt = Rt + 1
Rs = Rs + 1
Loop While WsNum.Cells(Rs, NwsCode).Value = RegCode
Else
RegCode = ""
End If
End If
If Len(RegCode) = 0 Then
WsOut.Cells(Rt, NwsCode).Value = RegName
WsOut.Cells(Rt, NwsSubCode).Value = "No sub-code found"
Rt = Rt + 1
End If
Next R
End With
End Sub
And here are the conditions.
All 3 sheets must be in the same workbook. If you have them in different workbooks the code must be adapted to handle more than one workbook.
The two worksheets with data must exist. They must be named as the code prescribes or the code must be modified to match the names they have. The same goes for the Output worksheet, but that sheet will be created by the code if it doesn't exist. You can change its name in the code.
The enumeration at the top of the code presumes that all 3 sheets are identically formatted with no data in row 1 (captions) and data in columns A, B and C. Changes aren't difficult but must be made if you want a different input or output. You can change the columns in the existing code by assigning other values to the columns in the enum, but the code requires the same arrangement in all sheets.
The extracted codes in the Codes sheet aren't used. The code does its own extraction. It will mark an error in the output list if a code can't be extracted or if it isn't found in the Sub-code list.
The sub-codes in the Numer sheet must be sorted like the picture you posted. The code will look for the first occurrence of "image" and find the subcodes in the following rows while the code is "image" in column A. It will not find further occurrences of "image" that might follow after an intermission.
The code doesn't do any colouring. Adding it wouldn't be difficult, but you would have to specify some rules, such as "20 different colours for the first 20 codes and then repeat the same sequence".
Other cell formatting could be added without much effort because each cell is already individually named. More properties can be added easily.
I've built a name range for 20 cells so that I can input a new list of projects which will vary from 1 to 20. I want to write a macro so that it reads the number of projects and creates the correct number of tabs, and names the tab after the project name listed in the named range. I've done all of this except I can't get the countA function to work. The named range is csCount. if I change the For loop to the correct number in one instance (if I put 7 because right now I have 7 projects) the loop and macro are correct. I want to make it more dynamic using the countA. Thank you very much for the help.
Sub generateDepartments()
Dim tabs As Integer
Dim sName As String
Dim i As Integer
Dim j As Integer
Dim csCount As Variant
tabs = Application.CountA(csCount)
j = 5
i = tabs
For i = 2 To Application.CountA(csCount)
Worksheets("Input").Activate
sName = Cells(j, 3).Value
Worksheets.Add(after:=Worksheets(i)).Name = sName
j = j + 1
Next
End Sub
First you need to create a variable to access your named range: Set csCount = ActiveWorkbook.Names("csCount").RefersToRange or Set csCount = ActiveSheet.Range("csCount")
Then use Application.WorksheetFunction.CountA(csCount)
Also, is better to define as a Range instead of Variant Dim csCount As Range
I have for example a column of 18000 domains and another list with 210.000 domain which those 18000 domains can be found. I need to do smth like CTRL + H, for find and replace, and in the find field I need to add the entire 18000 domains: smth like * domain1.com *, * domain2.com *, * domain3.com * and replace them with blank space. Tried this with find and replace from excel but it doesn't work to add more than 1 value in the Find field. How can i do it for multiple values?
VBA solution
You will need to change the two sheet references (data and edit sheet) data = source, edit = destination. I've also set the replace string to a variable so you can change this from an empty string if required.
If you need any other logic (ie Trim the strings before compare or a change to the strings case comparison) the code should be reasonably easy to tweak.
Hope this helps.
Sub ReplaceValues()
Dim dataSht As Worksheet
Dim editSht As Worksheet
Dim dataRange As Range
Dim dataColumn As Long
Dim editColumn As Long
Dim dataEndRow As Long
Dim editEndRow As Long
'sheet that holds all the values we want to find
Set dataSht = Sheet2
'sheet we want to edit
Set editSht = Sheet1
Dim replaceValue As String
'replace value is empty string
replaceValue = ""
'set the column of the data sheet to A
dataColumn = 1
'set the colmun of the sheet to edit to A
editColumn = 1
dataEndRow = dataSht.Cells(dataSht.Rows.count, dataColumn).End(xlUp).Row
editEndRow = editSht.Cells(editSht.Rows.count, editColumn).End(xlUp).Row
'this is the range of the data that we're looking for
Set dataRange = dataSht.Range(dataSht.Cells(1, dataColumn), dataSht.Cells(dataEndRow, dataColumn))
Dim count As Long
Dim val As String
For i = 1 To editEndRow
val = editSht.Cells(i, editColumn).Value
count = Application.WorksheetFunction.CountIf(dataRange, val)
If count > 0 And Trim(val) <> "" Then
editSht.Cells(i, editColumn).Value = replaceValue
End If
Next i
End Sub
You can use wildcards with find/replace. So in your situation you should be able to use something like
domain* in the find what Field and nothing in the Replace field
I would like to create a macro in excel that lets me increment the counts of a part whenever I press a command button.
Currently, my concept is to use vlookup to get the existing counts for that part using the following. However, it does not increment the actual counts value in the cell, which is what I want. I suspect it's cos vlookup is only used to return a value within the cell, but the cell is not activated in the process for actual increment. Can someone please advise how I can correct it? I'm still new to vba. Thanks!!! :)
E.g. Vlookup finds C1value in Cell A5 of Sheets("Location"). It will automatically increment the value in Cell C5 by 1.
Sub FindAddTools()
Dim C1Qnty As Double
C1value = Sheets("Issue").Range("D11")
Sheets("Location").Activate
C1Qnty = WorksheetFunction.VLookup(C1value, Range("A:D"), 3, False)
C1Qnty = C1Qnty + 1
End Sub
ADD ON: an add-on to my original question. I was wondering if it is possible to do the same for an entire range?
E.g. C1value is now a range of Sheets("Issue").Range("D11:D20"). I want to find all values within this range in Sheets("Location") and increment their corresponding counts in Column C.
Is there a way to do this without repeating the same procedure for all cells of the range?
Thanks! :)
Here's my shot at it. If the value isn't matched nothing happens:
Sub FindAddTools()
Dim RangeToMatch As Excel.Range
Dim cell As Excel.Range
Dim C1Value As Variant
Dim C1Row As Variant
Set RangeToMatch = Sheets("Issue").Range("D2:D11")
For Each cell In RangeToMatch
C1Value = cell.Value
With Sheets("Location")
C1Row = Application.Match(C1Value, .Range("A:A"), 0)
If Not IsError(C1Row) Then
.Range("C" & C1Row).Value = .Range("C" & C1Row).Value + 1
End If
End With
Next cell
End Sub
I edited it so that it cycles through a range of cells to match. That range is set to D2:D11 above.
Based on your comments, I think this should do it.
NB: you don't have to Activate worksheets to perform the functions referencing their cells/ranges.
Sub FindAddTools()
Dim shIssue as WOrksheet: Set shIssue = Sheets("Issue")
Dim shLoc as Worksheet: Set shLoc = Sheets("Location")
Dim allC1Values as Range
Dim C1Value as Variant
Dim C1Qnty As Double
Dim foundRow as Long
Set allC1Values = shIssue.Range("D11:D100") '## Modify as needed.
For each C1Value in allC1Values.Cells
C1Qnty = WorksheetFunction.VLookup(C1value, shLoc.Range("A:D"), 3, False)
C1Qnty = C1Qnty + 1
foundRow = WorksheetFunction.Match(c1Value,shLoc.Range("A:A"),False)
shLoc.Range("C" & foundRow).Value = CqQnty
Next
End Sub
Be careful with this. You're immediately writing to the same cell you just "found" with the VLOOKUP function, so, obviously if you run this macro again, you're going to increment it again. But, this may be the desired functionality, if so, no problem.
NOTE: There is no error trapping for if C1Value is not found in the VLOOKUP or MATCH functions.