I've been working on what is basically a register for sales. My spreadsheet records sales, profits etc and from that prints a receipt however, I'd like to keep my own record of this data to use for graphs etc. At the moment my macro moves up from a specified column, beginning from row 100000, then when it reaches a row with data, moves down one to the empty cell. In it it places the cell reference for the new data it has found. I'm new to VBA so I'm not sure if I'm taking the right approach, this is my code:
Sub DataLog()
'
' DataLog Macro
' Record sales in the data log.
'
'
Sheets("Data").Select
Dim rngd As Range
Set rngd = Range("A100000").End(xlUp).Offset(1, 0)
Dim coke As Range
Set coke = Range("C100000").End(xlUp).Offset(1, 0)
Dim creamsoda As Range
Set creamsoda = Range("D100000").End(xlUp).Offset(1, 0)
Dim lemonade As Range
Set lemonade = Range("E100000").End(xlUp).Offset(1, 0)
Dim pasito As Range
Set pasito = Range("F100000").End(xlUp).Offset(1, 0)
Dim pepsi As Range
Set pepsi = Range("G100000").End(xlUp).Offset(1, 0)
Dim pepsim As Range
Set pepsim = Range("H100000").End(xlUp).Offset(1, 0)
Dim solo As Range
Set solo = Range("I100000").End(xlUp).Offset(1, 0)
Dim sprite As Range
Set sprite = Range("J100000").End(xlUp).Offset(1, 0)
Dim sunkist As Range
Set sunkist = Range("K100000").End(xlUp).Offset(1, 0)
Dim water As Range
Set water = Range("L100000").End(xlUp).Offset(1, 0)
rngd.Value = "=Form!D1"
coke.Value = "=Form!E7"
creamsoda.Value = "=Form!E8"
lemonade.Value = "=Form!E9"
pasito.Value = "=Form!E10"
pepsi.Value = "=Form!E11"
pepsim.Value = "=Form!E12"
solo.Value = "=Form!E13"
sprite.Value = "=Form!E14"
sunkist.Value = "=Form!E15"
water.Value = "=Form!E16"
When I clock the macro button, the first time it works, as does it the second time. Although, when it does record the second set of data in the row below, it updates all the previous data in each cell. How can I stop any previously entered data from being updated so I can keep a weekly record of information? Any help or insight is greatly appreciated, thank you :)
EDIT:
I should add, I have tried locking the cells once data has been added but this only protected them from manual alteration, the macro still updated the data.
To overwrite the all formulas in your Data sheet with values, add these two lines to the bottom of your script:
Sheets("Data").Cells.Copy
Sheets("Data").Cells.PasteSpecial (xlPasteValues)
If there are formulas you want to keep, you'll simply need to define the Range of soda values you do want to overwrite and follow the same pattern:
Dim SodaData As Range
'ex below sets SodaData range from A3 to C3
Set SodaData = Sheets("Data").Range(Sheets("Data").Cells(3, 1), Sheets("Data").Cells(3, 3))
SodaData.Copy
SodaData.PasteSpecial (xlPasteValues)
Related
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'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)
I'm trying to simplify an excel file I receive every week for my team's travel plans.
It has the team member's name, flight #, and arrival time.
I have team members come in on different flight sometimes. I like to visually see who will arrive at what time so I can easily make rental car arrangements. If a group arrives at 1:06, I'll highlight those together and another at 6:55 - I'll highlight those. We could have as many as 15 different flight plans. I currently use conditional formatting to identify the common ones, but since I do this every week for 50 people it would be convenient to through into a vba module to run. ( I already have a module reformatting some columns/rows).
I've looked at repeating code identifiers and this as my main resource
Compare Dates/Times but no luck so far.
Picture of what I do now:
highlight
The way I have coded is that the data is formatted into a table, then unique values in the 'Flight #' column are calculated. The data is then sequentially filtered by these values and the rows are coloured from a predetermined palette (which can be altered).
Sub FormatDuplicateRows()
Dim wsFlight As Worksheet: Set wsFlight = Worksheets("Flights")
On Error Resume Next
If Not wsFlight.ListObjects("Flights") Is Nothing Then wsFlight.ListObjects("Flights").Unlist
On Error GoTo 0
wsFlight.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name = "Flights"
Dim tblFlight As ListObject: Set tblFlight = wsFlight.ListObjects("Flights")
Dim Fld As Long: Fld = tblFlight.ListColumns("Flight #").Range.Column
Dim Dict As Object: Set Dict = CreateObject("Scripting.Dictionary")
For Each Cell In tblFlight.ListColumns("Flight #").DataBodyRange
If Not Dict.Exists(Cell.Value) Then Dict.Add Cell.Value, Cell.Address
Next
Dim Colours() As String: Colours = Split("&HD9E9FD,&HF3EEDB,&HECE0E5,&HDDF1EA,&HDCDDF2,&HCCFFFF", ",")
Dim i As Long: i = 0
With tblFlight
.TableStyle = "TableStyleLight1"
.ShowTableStyleRowStripes = False
For Each Value In Dict.Keys
.Range.AutoFilter Field:=Fld, Criteria1:=Value
.DataBodyRange.SpecialCells(xlCellTypeVisible).Interior.Color = Colours(i)
i = IIf(i = UBound(Colours), 0, i + 1)
Next Value
.Range.AutoFilter Field:=Fld
End With
End Sub
You can alter the palette to your requirements and the palette will auto-repeat once all the colours have been used once
********* UPDATE **********
To get the colour values for the array I coded the following function
Public Function GetColour(rngSrc As Range) As String
GetColour = "&H" & Application.WorksheetFunction.Dec2Hex(rngSrc.Interior.Color)
End Function
Then in an excel workbook, I just placed the formula =GetColour("A1") in "A2" and altered the fill colour of some cells along row 1 then drag-dropped the formula to get the hex values of the fill colours I wanted
I have a large data set which I need to manipulate and create individual worksheets. Within column B all cells which are coloured Green I would like to make a new worksheet for. Please see screen shot.
For example I would like to create worksheets titled "Shopping" & "Retail". Once the worksheet is created, I would then like to copy all the data between the "worksheet title" (Green Cells) from columns ("B:C") & ("AI:BH") Please see screen shot below for expected output;
The code I have so far is below as you can see it is not complete as I do not know how I would go about extracting data between the "Green Cells".
Sub wrksheetadd()
Dim r As Range
Dim i As Long
Dim LR As Long
Worksheets("RING Phased").Select
LR = Range("B65536").End(xlUp).Row
Set r = Range("B12:B" & (LR))
For i = r.Rows.Count To 1 Step -1
With r.Cells(i, 1)
If .DisplayFormat.Interior.ColorIndex = 35 Then
MsgBox i
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Cells (i,1).Value
Worksheets("RING Phased").Select
End If
End With
Next i
End Sub
Any help around this would be much appreciated.
Sorry for taking a while to get back to this, I've been somewhat busy the last few days, so I haven't had much time to be on StackOverflow.
Anyway, the way I'd go about this would be to store all the found values in an array, and then loop through that array in order to find the distance between them.
The following code works for me, using some very simplified data, but I think the principle is sound:
Option Explicit
Option Base 0
Sub wrksheetadd()
Dim r As Range, c As Range
Dim i As Long: i = 0
Dim cells_with_color() As Range: ReDim cells_with_color(1)
With Worksheets("RING Phased")
' Since it doesn't seem like the first cell you want to copy from is colored, hardcode that location here.
' This also saves us from having to test if the array is empty later.
Set cells_with_color(i) = .Range("B12")
i = i + 1
Set r = Range(.Range("B13"), .Range("B" & .Cells.Rows.Count).End(xlUp))
' Put all the cells with color in the defined range into the array
For Each c In r
If c.DisplayFormat.Interior.ColorIndex = 35 Then
If i > UBound(cells_with_color) Then
ReDim Preserve cells_with_color(UBound(cells_with_color) + 1)
End If
Set cells_with_color(i) = c
i = i + 1
End If
Next
' Loop through the array, and copy from the previous range value to the current one into a new worksheet
' Reset counter first, we start at 1, since the first range-value (0 in the array) is just the start of where we started checking from
' (Hmm, reusing variables may be bad practice >_>)
i = 1
While i <= UBound(cells_with_color)
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = cells_with_color(i).Value
' Set the range to copy - we could just do this in the copy-statement, but hopefully this makes it slightly easier to read
Set r = .Rows(CStr(cells_with_color(i - 1).Row) + 1 & ":" & CStr(cells_with_color(i).Row))
' Change the destination to whereever you want it on the new sheet. I think it has to be in column one, though, since we copy entire rows.
' If you want to refine it a bit, just change whatever you set r to in the previous statement.
r.Copy Destination:=Worksheets(CStr(cells_with_color(i).Value)).Range("A1")
i = i + 1
Wend
End With
End Sub
It probably lacks some error-checking which ought to be in there, but I'll leave that as an exercise to you to figure out. I believe it is functional. Good luck!
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.