I create an array "Checkarray()" to collect the A column data in worksheet "Gun Log". After that I create a "For" loop function for the A column data in worksheet "Gun Inventory".
By comparing the data in two worksheets I am trying to use the Match function to locate where there is a data match, and transferring the corresponding date from one worksheet to the other.
No matter how I adjust conditions the date transfer is always "10/1/2018". I don't know where this is from.
If there are several different results matched in one worksheet, which result will the match function give at the end? In the "Gun Log" worksheet for each gun there are several matched results and I suspect that is the cause of the error.
Private Sub submitBt_Click()
Dim i As Integer
Dim c As Long
Dim g As Long
Dim CheckArray() As String
With ThisWorkbook.Sheets("Gun Log")
For c = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
ReDim Preserve CheckArray(c - 1)
CheckArray(c - 1) = .Cells(c, "A").Value
Next c
End With
For g = 1 To UBound(CheckArray) Step 1
If UCase(CheckArray(g)) = UCase(.Cells(i, "A")) Then
.Cells(i, "E") = Worksheets("Gun Log").Cells(Application.Match(CheckArray(g), .Columns(1)) + 1, "B").Value
Debug.Print Application.Match(CheckArray(g), .Columns(1))
Debug.Print Worksheets("Gun Log").Cells(Application.Match(CheckArray(g), .Columns(1)) + 1, "B").Value
End If
Next g
Next i
End With
End Sub
Try to use all the arguments of Match() so that you can ensure you have an exact match.
You might be matching partially, which is why you only have one output. You used:
Worksheets("Gun Log").Cells(Application.Match(CheckArray(g), .Columns(1)) + 1, "B").Value
'AND
Application.Match(CheckArray(g), .Columns(1))
The third argument for match is if it should be an exact match, so try:
Worksheets("Gun Log").Cells(Application.Match(CheckArray(g), .Columns(1), 0) + 1, "B").Value
'AND
Application.Match(CheckArray(g), .Columns(1), 0)
That "0" I added (third argument) means you need an exact match.
Related
I have existing script that does a major chunk of what I need. The script (from here: https://www.extendoffice.com/documents/excel/4054-excel-duplicate-rows-based-on-cell-value.html) basically inserts and then copies rows of data X number of times, where X is one of the fields in the table. It works well and the referenced page shows examples of the start and end points.
But when I run the script in Excel I go from ~2,000 lines in my table to ~40,000 lines. I need to modify all the duplicated rows (incremental dates) and so I am now attemting to also include new data into the table while the script runs that will allow me to change data in the duplicated rows... for example I can use the duplicate number 1, 2, 3, 4 and some simple formulas to change dates relative to a start point.
I expect that I will need some additional code inserted into the routine that will add data into a nominated column and do the auto incrementing from 1.
Having zero actual VBA skillz, ive no idea how to tackle the second part of my problem with the code I already have. Any help would be totally awesome !!
Sub CopyData()
'Updateby Extendoffice 20160922
Dim xRow As Long
Dim VInSertNum As Variant
xRow = 1
Application.ScreenUpdating = False
Do While (Cells(xRow, "A") <> "")
VInSertNum = Cells(xRow, "D")
If ((VInSertNum > 1) And IsNumeric(VInSertNum)) Then
Range(Cells(xRow, "A"), Cells(xRow, "D")).Copy
Range(Cells(xRow + 1, "A"), Cells(xRow + VInSertNum - 1, "D")).Select
Selection.Insert Shift:=xlDown
xRow = xRow + VInSertNum - 1
End If
xRow = xRow + 1
Loop
Application.ScreenUpdating = False
End Sub
Try this code below, I used the same sample data on the link you provided. However on this code I created 2 worksheets, one for the raw data to be processed and one for the duplicate output including the increment of dates and duplicate number.
Sub duplicateData()
Dim rSH As Worksheet
Set rSH = ThisWorkbook.Sheets("RAW") 'Your raw data
Dim oSH As Worksheet
Set oSH = ThisWorkbook.Sheets("OUTPUT") 'Output data on another sheet
x = 2
For a = 2 To rSH.Range("A" & Rows.Count).End(xlUp).Row
For b = 1 To rSH.Cells(a, 4).Value '4 is the column of duplicate times
If b = 1 Then
For c = 1 To 4 'Number of your column
oSH.Cells(x, c).Value = rSH.Cells(a, c).Value
Next c
oSH.Cells(x, 5) = 1 'First instance, 5 is the column number of duplicate counter
Else
For c = 1 To 4 'Number of your column
oSH.Cells(x, c).Value = rSH.Cells(a, c).Value
Next c
oSH.Cells(x, 3).Value = CDate(oSH.Cells(x - 1, 3).Value) + 1 '3 is the column number of date to increment
oSH.Cells(x, 5).Value = CInt(oSH.Cells(x - 1, 5).Value) + 1 '5 is the column number of duplicate counter
End If
x = x + 1 'Increment Output row number
Next b
Next a
End Sub
I have a shared excel sheet with records being entered all the time. I want to find the last consecutive entry of a specific Name(its 'A' in this example) and record the value at the begining and ending of last occurance.
The output of the attached excel should be
A,2,34 ---when i open when there were 5 entries
A,5,null ---when i opened when there were 9 entries
A,9,6 ---when i opened when there were 11 entries
A,9,3 ---when i opened when there were 12 entries
please help me with the formula that i can use in a different tab of same excel.
Thanks
this should work.
in column C use this formula. Works from row2 and down. row1 should be irrelevant (no consecutive entries at this point).
=IF(B1=B2,B2&","&A1&","&A2,"")
You can also have a formula display whatever is the last entry for that value. This is for value "A".
=LOOKUP(2,1/(B:B=E1),C:C)
A UDF should be able to handle the relative loop.
Option Explicit
Function LastConColVals(rng As Range, crit As String, _
Optional delim As String = ",")
Dim tmp As Variant, r As Long, rr As Long
'allow full column references
Set rng = Intersect(rng, rng.Parent.UsedRange)
With rng
tmp = Array(crit, vbNullString, vbNullString)
For r = .Rows.Count To 1 Step -1
If .Cells(r, 2).Value = crit Then
tmp(2) = .Cells(r, 1).Value
For rr = r To 1 Step -1
If .Cells(rr, 2).Value = crit Then
tmp(1) = .Cells(rr, 1).Value
Else
Exit For
End If
Next rr
'option 1 - null last value for singles
If rr = (r - 1) Then tmp(2) = "null"
'option 2 - truncate off last value for singles
'If rr = (r - 1) Then ReDim Preserve tmp(UBound(tmp) - 1)
Exit For
End If
Next r
End With
LastConColVals = Join(tmp, delim)
End Function
How can I set up a macro that will strip the letters from #####XX in column I and put them in to column L same row? Thanks!
Assuming you're working with the first sheet and you're always stripping off the last two characters while leaving the first 5 characters, the following code will work:
Public Sub StripOff()
Dim iRow as Integer
iRow = 2 'Assuming row 1 is headers, else make this 1
While Sheets(1).Range("I" + Cstr(iRow)).Value <> ""
Sheets(1).Range("L" + CStr(iRow)).Value = Right(Sheets(1).Range("I" + Cstr(iRow)).Value, 2)
Sheets(1).Range("I" + Cstr(iRow)).Value = Left(Sheets(1).Range("I" + Cstr(iRow)).Value, 5)
iRow = iRow + 1
Wend
End Sub
The operative words I'm understanding from your question are Cutting and strip. To my mind, this means that the last two letters are permanently removed from column I and placed in column L.
Sub cut2right()
Dim v As Long, vPFXS As Variant, vSFXS As Variant
With Worksheets("Sheet6")
vPFXS = .Range(.Cells(2, "I"), .Cells(Rows.Count, "I").End(xlUp))
ReDim vSFXS(1 To UBound(vPFXS), 1 To 1)
For v = LBound(vPFXS, 1) To UBound(vPFXS, 1)
If Len(vPFXS(v, 1)) > 1 Then
vSFXS(v, 1) = Right(vPFXS(v, 1), 2)
vPFXS(v, 1) = Left(vPFXS(v, 1), Len(vPFXS(v, 1)) - 2)
End If
Next v
.Cells(2, "I").Resize(UBound(vPFXS, 1), 1) = vPFXS
.Cells(2, "L").Resize(UBound(vPFXS, 1), 1) = vSFXS
End With
End Sub
Working with variant arrays should speed up working with many cells with variable length string values. If they were all the same length then manually running a Text-to-Columns command with a fixed length to an unused column and then copying and pasting the results to the appropriate column would have done just fine.
You can get the leading numeric characters from a string using the VBA Val function. To use this function on a worksheet you will need to create a User Defined Function (UDF) in a standard VBA module.
Function LeadingNumbers(Str As String) As Double
LeadingNumbers = Val(Str)
End Function
Simply enter the function in a cell and reference the cell containing the string you want "cleaned".
I am having trouble determining a way to enter a 1 or 0 into an adjacent cell to indicate whether or not a value is unique when working with a large dataset. I have read of multiple methods for accomplishing this, however none of them seem efficient for my purposes: I am using an instance of Excel 2010 (so I do not have the Distinct Count feature in PivotTables, and when I try to use PowerPivot it crashes my file due to processing limitations.
In this StackOverflow question: Simple Pivot Table to Count Unique Values there are suggestions to use SUMPRODUCT or COUNTIF, but when working with 50,000+ rows as I am, this causes terrible performance and a file size of ~35 MB instead of ~3 MB. I wanted to know if there is a better solution for a large, dynamic dataset whether it is a formula or VBA.
An example of what I would like to accomplish is (with the Unique column being the adjacent cell):
Name Week Unique
John 1 1
Sally 1 1
John 1 0
Sally 2 1
I attempted to script the same functionality of COUNTIF but with no success:
For Each Cell In ThisWorkbook.Worksheets("Overtime & Type Data").Range("Z2:Z" & DataLastRow)
If Worksheets("Overtime & Type Data").Cells(Cell.Row, 26) <> Worksheets("Overtime & Type Data").Cells(Cell.Row - 1, 26) Then
FirstCell = Cell.Row
End If
If (Worksheets("Overtime & Type Data").Range(Cells(FirstCell, 26), Cells(Cell.Row, 26)) = Worksheets("Overtime & Type Data").Range(Cells(Cell.Row, 26))) = True Then
Cell.Value = 1
Else
Cell.Value = 0
End If
Next Cell
This code ran on over 130,000 rows successfully in less than 3 seconds. Adjust the column letters to fit your dataset.
Sub tgr()
Const colName As String = "A"
Const colWeek As String = "B"
Const colOutput As String = "C"
Dim ws As Worksheet
Dim rngData As Range
Dim DataCell As Range
Dim rngFound As Range
Dim collUniques As Collection
Dim arrResults() As Long
Dim ResultIndex As Long
Dim UnqCount As Long
Set ws = ThisWorkbook.Sheets("Overtime & Type Data")
Set rngData = ws.Range(colName & 2, ws.Cells(Rows.Count, colName).End(xlUp))
Set collUniques = New Collection
ReDim arrResults(1 To rngData.Cells.Count, 1 To 1)
On Error Resume Next
For Each DataCell In rngData.Cells
ResultIndex = ResultIndex + 1
collUniques.Add ws.Cells(DataCell.Row, colName).Value & ws.Cells(DataCell.Row, colWeek).Value, ws.Cells(DataCell.Row, colName).Value & ws.Cells(DataCell.Row, colWeek).Value
If collUniques.Count > UnqCount Then
UnqCount = collUniques.Count
arrResults(ResultIndex, 1) = 1
Else
arrResults(ResultIndex, 1) = 0
End If
Next DataCell
On Error GoTo 0
ws.Cells(rngData.Row, colOutput).Resize(rngData.Cells.Count).Value = arrResults
End Sub
One approach is to sort by Name and Week. Then you can determine Unique for any row by comparing with the previous row.
If you need to preserve the order, you could first write a column of Index numbers (1, 2, 3, ...) to keep track of order. After calculating Unique, sort by Index to restore the original order.
The whole process could be done manually with relatively few steps, or automated with VBA.
I'm not sure how well this will work with 50000 values, but it goes through ~1500 in about a second.
Sub unique()
Dim myColl As New Collection
Dim isDup As Boolean
Dim myValue As String
Dim r As Long
On Error GoTo DuplicateValue
For r = 1 To Sheet1.UsedRange.Rows.Count
isDup = False
'Combine the value of the 2 cells together
' and add that string to our collection
'If it is already in the collection it errors
myValue = Sheet1.Cells(r, 1).Value & Sheet1.Cells(r, 2).Value
myColl.Add r, myValue
If isDup Then
Sheet1.Cells(r, 3).Value = "0"
Else
Sheet1.Cells(r, 3).Value = "1"
End If
Next
On Error GoTo 0
Exit Sub
DuplicateValue:
'The value is already in the collection so put a 0
isDup = True
Resume Next
End Sub
Just about any bulk operation will beat a loop involving worksheet cells. You might be able to trim the time down a bit by performing all of the calculations in memory and only returning the values back to the worksheet en masse when it is complete.
Sub is_a_dupe()
Dim v As Long, vTMP As Variant, vUNQs As Variant, dUNQs As Object
Debug.Print Timer
On Error GoTo bm_Uh_Oh
Set dUNQs = CreateObject("Scripting.Dictionary")
With Worksheets("Sheet1")
vTMP = .Range(.Cells(2, 1), .Cells(Rows.Count, 2).End(xlUp)).Value2
ReDim vUNQs(1 To UBound(vTMP, 1), 1 To 1)
For v = LBound(vTMP, 1) To UBound(vTMP, 1)
If dUNQs.Exists(Join(Array(vTMP(v, 1), vTMP(v, 2)))) Then
vUNQs(v, 1) = 0
Else
dUNQs.Add Key:=Join(Array(vTMP(v, 1), vTMP(v, 2))), _
Item:=vTMP(v, 2)
vUNQs(v, 1) = 1
End If
Next v
.Cells(2, 3).Resize(UBound(vUNQs, 1), 1) = vUNQs
End With
Debug.Print Timer
bm_Uh_Oh:
dUNQs.RemoveAll
Set dUNQs = Nothing
End Sub
Previous experience tells me that the variety of data (as well as hardware, etc) will impact timing the process but in my random sample data I received these elapsed times.
50K records ..... 0.53 seconds
130K records .... 1.32 seconds
500K records .... 4.92 seconds
I have an excel sheet with the below (pipe "|" to delimit columns) data.
A|B|C|X|50|60
D|E|F|X|40|30
A|B|C|X|10|20
A|B|C|Y|20|20
A|B|C|X|20|70
D|E|F|X|10|50
A|B|C|Y|10|10
The result I am trying to get is:
A|B|C|X|80|150
A|B|C|Y|30|30
D|E|F|X|50|80
Values A, B, C and D, E, F are like unique identifiers. Actually only A or D can be considered. Values X and Y are like "types", and the integers are the values to sum. This sample was simplified, there are thousands of unique identifiers, dozen of types and dozens of values to sum. The rows are not sorted, the types can be located in higher or lower rows. I am trying to avoid the use of a pivot table.
Dim LastRow As Integer
Dim LastCol As Integer
Dim i As Integer
LastCol = Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
LastRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To LastRow
????
Next i
The code above gets to the point of looping through the rows but I am unclear on what to after that point.
Sort them on all alphabetic columns you deem important.
In an unused column to the right use a formula like the following in the second row,
=IF($A2&$B2&$C2&$D2=$A3&$B3&$C3&$D3, "", SUMIFS(E:E,$A:$A, $A2,$B:$B, $B2,$C:$C, $C2,$D:$D, $D2))
Copy that formula right one column then fill both columns down as far as your data goes
Filter on the two columns, removing blanks.
Optionally copy the data to a new report worksheet and remove columns E & F.
Addendum:
A more automated approach could be achieved with some form of array and some simple mathematical operations. I've chosen a dictionary object in order to take use of its indexed Key to recognize patterns in the first four alphabetic identifiers.
To use a scripting dictionary, you need to go into the VBE's Tools ► References and add Microsoft Scripting Runtime. The following code will not compile without it.
The following has been adjusted for dynamic columns of keys and integers.
Sub rad_collection()
Dim rw As Long, nc As Long, sTMP As String, v As Long, vTMP As Variant
Dim i As Long, iNumKeys As Long, iNumInts As Long
Dim dRADs As New Scripting.Dictionary
dRADs.CompareMode = vbTextCompare
iNumKeys = 5 'possibly calculated by num text (see below)
iNumInts = 2 'possibly calculated by num ints (see below)
With ThisWorkbook.Sheets("Sheet4").Cells(1, 1).CurrentRegion
'iNumKeys = Application.CountA(.Rows(2)) - Application.Count(.Rows(2)) 'alternate count of txts
'iNumInts = Application.Count(.Rows(2)) 'alternate count of ints
For rw = 2 To .Cells(Rows.Count, 1).End(xlUp).row
vTMP = .Cells(rw, 1).Resize(1, iNumKeys).Value2
sTMP = Join(Application.Index(vTMP, 1, 0), Chr(183))
If Not dRADs.Exists(sTMP) Then
dRADs.Add Key:=sTMP, Item:=Join(Application.Index(.Cells(rw, iNumKeys + 1).Resize(1, iNumInts).Value2, 1, 0), Chr(183))
Else
vTMP = Split(dRADs.Item(sTMP), Chr(183))
For v = LBound(vTMP) To UBound(vTMP)
vTMP(v) = vTMP(v) + .Cells(rw, iNumKeys + 1 + v).Value2
Next v
dRADs.Item(sTMP) = Join(vTMP, Chr(183))
End If
Next rw
rw = 1
nc = iNumKeys + iNumInts + 1
.Cells(rw, nc + 1).CurrentRegion.ClearContents 'clear previous
.Cells(rw, nc + 1).Resize(1, nc - 1) = .Cells(rw, 1).Resize(1, nc - 1).Value2
For Each vTMP In dRADs.Keys
'Debug.Print vTMP & "|" & dRADs.Item(vTMP)
rw = rw + 1
.Cells(rw, nc + 1).Resize(1, iNumKeys) = Split(vTMP, Chr(183))
.Cells(rw, nc + iNumKeys + 1).Resize(1, iNumInts) = Split(dRADs.Item(vTMP), Chr(183))
.Cells(rw, nc + iNumKeys + 1).Resize(1, iNumInts) = _
.Cells(rw, nc + iNumKeys + 1).Resize(1, iNumInts).Value2
Next vTMP
End With
dRADs.RemoveAll: Set dRADs = Nothing
End Sub
Just run the macro against the numbers you have provided as samples. I've assumed some form of column header labels in the first row. The dictionary object is populated and duplicates in the combined identifiers have their numbers summed. All that is left is to split them back up and return them to the worksheet in an unused area.
Location of Microsoft Scripting Runtime - In the Visual Basic Editor (aka VBE) choose Tools ► References (Alt+T,R) and scroll down a little more than halfway to find it.