I'm trying to create a macro to evaluate the data in a specific column each
row at a a time. The field/column name might be different each time.
I wish at the same time to be able to compile/amend data based upon the
number of same occurrences. In the example below each set can contain a
maximum amount of 3 records per document.
I want to have it evaluate ID and for the first instance leve ID = 1 but
then each subsequent value have added A-D, this would result in ID's 1, 1A,
1B - where 1B would only have 1 record.
eg.
ID Name
1 Bob
1 Mary
1 Jane
1 Tommy
1 Carl
1 Jeff
1 Gary
2 John
3 Paul
The ID's which fall into the secondary sets would have their data appended
to reflect. At the same time my hope is to be able to record this
information of ID's that have this occur, so I can run a secondary process
where it will search for the originating ID in another sheet, then create a
copy of this row/record and then append the data to create a matching set
for each occurrence.
eg - worksheet called Data
ID Name
1 Bob
1 Mary
1 Jane
1A Tommy
1A Carl
1A Jeff
1B Gary
2 John
3 Paul
MasterRecord - Other worksheet called Details
ID Name Address Total
1 Bob 3
2 John 1
3 Paul 1
1A Bob 3
1B Bob 1
I have got it to the point of getting information for the checking process
and checking eavh value versus the previous and then counting the
occurences.
But have hit a wall as I'm not sure how to get each set flagged whilst
keeping the count going correctly.
Sample code below, please assist?
Sub MultiDoc()
'
' To group sets of data together if they are the same, field and number of
occurrences per set to be entered manually
'
'
Dim FilePath As String
Dim CellData As String
Dim LastCol As Long
Dim LastRow As Long
LastCol = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
LastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
FilePath = Application.DefaultFilePath & "\auth.csv"
Open FilePath For Output As #2
Dim fieldCheck As String
fieldCheck = InputBox("Please enter in column letter for TARGET",
"Target Column")
Dim MaxValue As Integer
MaxValue = InputBox("Enter maximum number per document", "Maximum No")
Cells.Select
'Sort fieldCheck data
Dim oneRange As Range
Dim aCell As Range
Set oneRange = Selection
Set aCell = Range(Cells(2, fieldCheck), Cells(2, LastRow))
oneRange.Sort Key1:=aCell, Order1:=xlAscending, Header:=xlYes
Dim NextValue As String
NextValue = ""
Dim PrevValue As String
PrevValue = ""
Dim ValCount As Long
ValCount = 1
Dim SetCount As Long
SetCount = 0
Dim i As Long
For i = LastRow To 2 Step -1
NextValue = Cells(i, fieldCheck).Value
If NextValue = PrevValue Then
'ValCount = ValCount + 1
'strMsg = "Found " & ValCount & " - " & NextValue
'MsgBox strMsg, vbOKOnly, "Match Found"
If ValCount > MaxValue Then
strMsg = NextValue & " exceeded " & MaxValue
MsgBox strMsg, vbOKOnly, "Max Value Reached"
End If
Else
ValCount = 1
End If
PrevValue = Cells(i, fieldCheck).Value
Next i
Close #2
MsgBox ("Done")
Cells(1, 1).Select
End Sub
--
Are you =EXP(E:RT) or =NOT(EXP(E:RT)) in Excel? And do you wanna be? It’s
=TIME(2,DO:IT,N:OW) ! Join official Facebook page of this forum @
https://www.facebook.com/discussexcel
FORUM RULES
1) Use concise, accurate thread titles. Poor thread titles, like Please Help,
Urgent, Need Help, Formula Problem, Code Problem, and Need Advice will not get
quick attention or may not be answered.
2) Don't post a question in the thread of another member.
3) Don't post questions regarding breaking or bypassing any security measure.
4) Acknowledge the responses you receive, good or bad.
5) Jobs posting is not allowed.
6) Sharing copyrighted material and their links is not allowed.
NOTE : Don't ever post confidential data in a workbook. Forum owners and
members are not responsible for any loss.
---
You received this message because you are subscribed to the Google Groups "MS
EXCEL AND VBA MACROS" group.
To unsubscribe from this group and stop receiving emails from it, send an email
to excel-macros+unsubscr...@googlegroups.com.
To post to this group, send email to excel-macros@googlegroups.com.
Visit this group at http://groups.google.com/group/excel-macros.
For more options, visit https://groups.google.com/d/optout.
