I am trying to copy one row to an other workbook (only if there is a match) and i can accomplish that with a simple loop but i would like to use some better and possibly quicker method:
Set wbk = Workbooks.Open(FROM)
Set wskz = wbk.Worksheets("Sheet1")
Set wbi = Workbooks.Open(TO)
Set wski = wbi.Worksheets("Sheet1")
si = 5
Do While wski.Cells(si, 1).Text <> "END" ' loop through the values in column "A" in the "TO" workbook
varver = wski.Cells(si, 1).Text ' data to look up
s = 5
Do While wskz.Cells(s, 1).Text <> "END" ' table where we search for the data in the "FROM" workbook
If wskz.Cells(s, 1).Text = varver Then Exit Do
s = s + 1
Loop
If wskz.Cells(s, 1).Text <> "END" Then
' I am trying this copy method to replace the loop but it throws an error
wskz.Range(Cells(s, 1), Cells(s, 250)).Copy Destination:=wski.Range(Cells(si, 1), Cells(si, 250))
' this is the working loop:
'For i = 1 To 250
' wskz.Cells(s, i) = wski.Cells(si, i)
' i = i + 1
'End If
'Next i
The problem with the new copying method throws an error as it can be seen above.
Thank you in advance for your help!
Try to replace :
wskz.Range(Cells(s, 1), Cells(s, 250)).Copy Destination:=wski.Range(Cells(si, 1), Cells(si, 250))
by
wskz.Range(wskz.Cells(s, 1), wskz.Cells(s, 250)).Copy Destination:=wski.Range(wski.Cells(si, 1), wski.Cells(si, 250))
Or by :
Dim Rng1 As Range, Rng2 As Range
Set Rng1 = wskz.Range(wskz.Cells(s, 1), wskz.Cells(s, 250))
Set Rng2 = wski.Range(wski.Cells(si, 1), wski.Cells(si, 250))
Rng1.Copy Rng2
This should do exactly what you are looking for:
Sub test()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Dim SourceWS As Worksheet, DestWS As Worksheet
Set SourceWS = Workbooks.Open("FROM").Worksheets("Sheet1")
Set DestWS = Workbooks.Open("TO").Worksheets("Sheet1")
Dim runner As Variant, holder As Range
If IsError(Application.Match("END", DestWS.Range("A5:A" & Rows.Count), 0)) Or IsError(Application.Match("END", SourceWS.Range("A5:A" & Rows.Count), 0)) Then
SourceWS.Parent.Close False
DestWS.Parent.Close False
Exit Sub
End If
Set holder = DestWS.Range("A5:A" & Application.Match("END", DestWS.Range("A5:A" & Rows.Count), 0) + 3)
For Each runner In SourceWS.Range("A5:A" & Application.Match("END", SourceWS.Range("A5:A" & Rows.Count), 0) + 3)
If IsNumeric(Application.Match(runner.Value, holder, 0)) Then runner.EntireRow.Copy DestWS.Rows(Application.Match(runner.Value, holder, 0) + 4)
Next
SourceWS.Parent.Close True
DestWS.Parent.Close True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub
It is self-explaining to my eye, but if you have any questions, just ask :)
This Error often occures related to Copy-Methods. I also ran into this kind of Error when I had my Sub on Worksheet Level. Try to extract it to a seperate Modul.
Also it seems your references to the Cells are broken. You can find this explained in the docs for Range.Item.
Try this
With wskz
.Range(.Cells(s, 1), .Cells(s, 250)).Copy
End With
Related
I am trying to build a excel vba code that looks at data from three columns, takes the lowest 6 values of each variable (which there are four of) and also takes the adjacent column and pastes it in another sheet.
This is the input:
This is what I would like the output to be:
!
This is what the output actually is:
Actual Output
I stole a lot of this code from another post I saw, but it seems to be acting very randomly. I'm still not quite sure what the code is even doing, which is what makes it hard for me.
Any advice will help tremendously.
UPDATE: Using Ibo's fix on my sample data, it worked perfectly, however on my actual data it errored out. The reason I am doing this through a macro instead of manually is because it is a part of a much larger macro that is getting pieced together to predict production consumption of various raw materials and what needs to get staged.
Here's what happened:
Actual Input Data
Error 1004 Message and highlighted code
Output after failure
It looks like it got close, but didn't finish with the actual sort.
Sub TopPriorityPerPod()
Dim wsData As Worksheet
Dim wsDest As Worksheet
Dim rngData As Range
Dim rngFound As Range
Dim rngUnqGroups As Range
Dim GroupCell As Range
Dim lCalc As XlCalculation
Dim aResults() As Variant
Dim aOriginal As Variant
Dim lNumTopEntries As Long
Dim i As Long, j As Long, k As Long
'Change to grab the top X number of entries per category'
lNumTopEntries = 6
Set wsData = ActiveWorkbook.Sheets("copy") 'This is where your data is'
Set wsDest = ActiveWorkbook.Sheets("Sheet6") 'This is where you want to output it'
Set rngData = wsData.Range("A2", wsData.Cells(Rows.Count, "C").End(xlUp))
aOriginal = rngData.Value 'Store original values so you can set them back later'
'Turn off calculation, events, and screenupdating'
'This allows code to run faster and prevents "screen flickering"'
With Application
lCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
'If there are any problems with the code, make sure the calculation, events, and screenupdating get turned back on'
'On Error GoTo CleanExit
With rngData
'.Sort .Resize(, 1).Offset(, 1), xlAscending, .Resize(, 1).Offset(, 2), , xlDescending, Header:=xlYes
.Sort .Resize(, 1).Offset(, 1), xlDescending, Header:=xlYes
End With
With rngData.Resize(, 1).Offset(, 1)
.AdvancedFilter xlFilterInPlace, , , True
Set rngUnqGroups = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
.Parent.ShowAllData 'Remove the filter
ReDim aResults(1 To rngUnqGroups.Cells.Count * lNumTopEntries, 1 To 4)
i = 0
For Each GroupCell In rngUnqGroups
Set rngFound = .Find(GroupCell.Value, .Cells(.Cells.Count))
k = 0
If Not rngFound Is Nothing Then
For j = i + 1 To i + lNumTopEntries
If rngFound.Offset(j - i - 1).Value = GroupCell.Value Then
k = k + 1
aResults(j, 1) = rngFound.Offset(j - i - 1, -1).Value
aResults(j, 2) = rngFound.Offset(j - i - 1).Value
aResults(j, 3) = rngFound.Offset(j - i - 1, 1).Value
aResults(j, 4) = rngFound.Offset(j - i - 1, 2).Value
End If
Next j
i = i + k
End If
Next GroupCell
End With
'Output results'
wsDest.Range("A2").Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults
CleanExit:
'Turn calculation, events, and screenupdating back on'
With Application
.Calculation = lCalc
.EnableEvents = True
.ScreenUpdating = True
End With
If Err.Number <> 0 Then
'There was an error, show the error'
MsgBox Err.Description, , "Error: " & Err.Number
Err.Clear
End If
'Put data back the way it was
rngData.Value = aOriginal
End Sub
You can have different approaches. In this method I copy the data to another sheet called Result, then insert a table, sort the columns and then collect the range where the rows are more than 6 and then delete the whole rows at once, it will be really fast:
Sub Main()
Dim i As Long
Dim rng As Range
Dim tbl As ListObject
Dim WS As Worksheet
Dim WS2 As Worksheet
Set WS = Worksheets("Sheet1") 'this is where you have the data
Set WS2 = Worksheets.Add
WS2.Name = "Result"
WS.Range("A1").CurrentRegion.Copy
WS2.Paste
'sort priority column first
WS2.ListObjects.Add(xlSrcRange, Range(WS2.UsedRange.Address), , xlYes).Name = "Table1"
Set tbl = WS2.ListObjects("Table1")
tbl.Sort.SortFields.Add _
Key:=Range("Table1[[#All],[Priority]]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
With tbl.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'sort station column
tbl.Sort.SortFields.Clear
tbl.Sort.SortFields.Add _
Key:=Range("Table1[[#All],[Station]]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
With tbl.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'remove any row exceeding 6th occurrence
Dim cnt As Integer
For i = 1 To tbl.ListRows.Count - 1
If tbl.ListColumns("Station").DataBodyRange(i, 1).Value = tbl.ListColumns("Station").DataBodyRange(i + 1, 1).Value Then
cnt = cnt + 1
If cnt >= 6 Then
If rng Is Nothing Then
Set rng = tbl.ListColumns("Station").DataBodyRange(i + 1, 1)
Else
Set rng = Application.Union(rng, tbl.ListColumns("Station").DataBodyRange(i + 1, 1))
End If
End If
Else
cnt = 0 'reset the counter
End If
Next i
'remove rows
If Not rng Is Nothing Then
tbl.Unlist
rng.EntireRow.Delete
End If
End Sub
So I've put something together for you that should get you most of the way there.
You'll need to do a few things to get this working for your file (learning opportunity!):
(1) Adjust the ranges as relevant to your file
(2) Print the output to the worksheet. As of right now the output is being printed to the immediate debug window.
What this code will do is sort out each letters values into a collection named after the letters.
From there we convert the collection to an array. We then utilize the "Small" worksheet function on the arrays, and loop through the 6 lowest values.
Happy to help with any further questions you may have!
Public Function CollectionToArray(myCol As Collection) As Variant
'Thanks to user Vityata for this converter function (https://stackoverflow.com/users/5448626/vityata).
Dim result As Variant
Dim cnt As Long
ReDim result(myCol.Count - 1)
For cnt = 0 To myCol.Count - 1
result(cnt) = myCol(cnt + 1)
Next cnt
CollectionToArray = result
End Function
Sub ArraySort()
Dim Cell As Range
Dim KeyMultiple As String
Dim collA As New Collection
Dim collB As New Collection
Dim collC As New Collection
Dim collD As New Collection
Dim Rng_Col As Range
Set Rng_Col = Sheets("Sheet1").Range("A2:A22")
Dim GroupByArr As Variant
GroupByArr = Array("A", "B", "C")
Counter = 0
For i = 1 To 22
If Cells(i, 1).Value = "A" Then
Counter = Counter + 1
KeyMultiple = Letter & "-" & Counter
collA.Add Item:=Cells(i, 2), Key:=KeyMultiple
ElseIf Cells(i, 1).Value = "B" Then
Counter = Counter + 1
KeyMultiple = Letter & "-" & Counter
collB.Add Item:=Cells(i, 2), Key:=KeyMultiple
ElseIf Cells(i, 1).Value = "C" Then
Counter = Counter + 1
KeyMultiple = Letter & "-" & Counter
collC.Add Item:=Cells(i, 2), Key:=KeyMultiple
ElseIf Cells(i, 1).Value = "D" Then
Counter = Counter + 1
KeyMultiple = Letter & "-" & Counter
collD.Add Item:=Cells(i, 2), Key:=KeyMultiple
End If
Next i
For i = 1 To 6
Debug.Print WorksheetFunction.Small(CollectionToArray(collA), i)
Debug.Print WorksheetFunction.Small(CollectionToArray(collB), i)
Debug.Print WorksheetFunction.Small(CollectionToArray(collC), i)
Debug.Print WorksheetFunction.Small(CollectionToArray(collD), i)
Next i
Set collA = New Collection
Set collB = New Collection
Set collC = New Collection
Set collD = New Collection
End Sub
here's a solution exploiting Array, Dictionary and SortedList object, that shuold be quite fast:
Option Explicit
Sub main()
Dim wsData As Worksheet: Set wsData = ActiveWorkbook.Sheets("copy") 'This is where your data is'
Dim wsDest As Worksheet: Set wsDest = ActiveWorkbook.Sheets("Sheet6") 'This is where you want to output
Dim stations As Variant, station As Variant
Dim iStation As Long
Dim stationsList As Object: Set stationsList = CreateObject("Scripting.Dictionary") ' use dictionary to collect unique station values
With wsData
stations = .Range("B2", .Cells(.Rows.Count, 2).End(xlUp)).Resize(, 3).Value
For iStation = 1 To UBound(stations, 1)
stationsList(stations(iStation, 1)) = stationsList(stations(iStation, 1)) & stations(iStation, 2) & "|" & stations(iStation, 3) & " " ' update current station priorities list and orders
Next
End With
Dim prioritiesAndOrders As Variant, priorityAndOrder As Variant, priority As Variant, order As Variant
Dim iPriority As Long, nPriorities As Long
For Each station In stationsList.Keys ' loop through unique stations
prioritiesAndOrders = Split(Trim(stationsList(station)), " ") ' get current station priorities and corresponding orders list
With CreateObject("System.Collections.SortedList") ' cerate and reference a sortedList object (it stores keys in ascending order)
For Each priorityAndOrder In prioritiesAndOrders ' loop through current station priorities and corresponding orders list
priority = Split(priorityAndOrder, "|")(0) ' get current priority
order = Split(priorityAndOrder, "|")(1) 'get current priority corresponding order
.Add priority, order ' store current priority as "key" of SortedList object and its corresponding order as its value
Next
nPriorities = WorksheetFunction.Min(.Count - 1, 5) ' define the current station number of priorities to manage
ReDim results(1 To nPriorities + 1, 1 To 3) As Variant ' size results array accordingly
For iPriority = 0 To nPriorities ' loop through current station sorted priorities (and corresponding orders) and fill results array with current station in column 1, its priorities in column 2 and priority corresponding order in column 3
results(iPriority + 1, 1) = station
results(iPriority + 1, 2) = .GetKey(iPriority)
results(iPriority + 1, 3) = .GetValueList()(iPriority)
Next
End With
wsDest.Cells(wsDest.Rows.Count, 1).End(xlUp).Offset(1).Resize(nPriorities + 1, 3).Value = results ' write current station sorted priorities
Next
End Sub
My problem is stated in the title. The error occurs in the first line with .Copy, but I have had it the same as the second one and received the same error.
I have checked so that the Sheet names are correct, and even copied them straight from the Sheet title in case some weird character sneaked in.
I'll put snippets of code here and then the full code in the end in case the problem is something different.
Declaration:
(I have tried setting it explicitly with Workbooks() but it didn't help)
Dim wb As Workbook
Set wb = ThisWorkbook' Or Workbooks("collected.xlsm")
Dim sUser As Worksheet, sExceptions As Worksheet
Set sUser = wb.Sheets("User")
Set sExceptions = wb.Sheets("Exceptions")
Copying:
sUser.Range(Cells(rS, 1)).Copy Destination:=sExceptions.Range(Cells(Count, 1))
sUser.Range(rS, 11).Copy Destination:=sExceptions.Range(Count, 2)
Entire code:
Option Explicit
Function FindExceptions()
' To run faster
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Variable def
Dim Count As Integer
' Variable def
' Worksheets
Dim wb As Workbook
Set wb = ThisWorkbook ' Or Workbooks("collected.xlsm")
Dim sUser As Worksheet, sVCD As Worksheet, sFullExport As Worksheet
Set sUser = wb.Sheets("User")
Set sVCD = wb.Sheets("VCD")
Set sFullExport = wb.Sheets("FullExport")
' r, f, c = Search, Find, Check
' For Each rows
Dim rS As Integer, rF As Integer, rC As Integer
'Set rS = sUser.Columns("A")
'Set rF = sVCD.Columns("A")
'Set rC = sFullExport("B")
' Vars used in execution
'Dim cS As Range, cF As Range, cC As Range
Dim secId As String, employeeNum As String, FoundVCD As Boolean, FoundFullExport As Boolean
' Go through User sheet
For rS = 2 To sUser.UsedRange.Rows.Count
secId = sUser.Cells(rS, "A").Value
employeeNum = sUser.Cells(rS, "K").Value
' Search for in VCD
FoundVCD = False
For rF = 2 To sVCD.UsedRange.Rows.Count
If sVCD.Cells(rF, "A").Value = secId And sVCD.Cells(rF, "K").Value = employeeNum Then
FoundVCD = True
Exit For
End If
Next
'Search for in Full Export?
If FoundVCD = True Then
FoundFullExport = False
For rC = 2 To sFullExport.UsedRange.Rows.Count
If sFullExport.Cells(rC, "B").Value = secId Then
FoundFullExport = True
Exit For
End If
Next
End If
If FoundFullExport = False Then
' WriteExceptions sUser.Cells(rS, "A").Value, sUser.Cells(rS, "K").Value, sFullExport.Cells(rC, "A").Value, sFullExport.Cells(rC, "D").Value
' Worksheet var
Dim sExceptions As Worksheet
Set sExceptions = wb.Sheets("Exceptions")
If Count = Null Or Count = 0 Then
sExceptions.Cells(1, "A") = "Säk. Id"
sExceptions.Cells(1, "B") = "Anst. Nr"
sExceptions.Cells(1, "C") = "Unison Id"
sExceptions.Cells(1, "D") = "Kort hex"
Count = 2
Else
Count = Count + 1
End If
' secId on col A, employeeNum on col B, unisonId on col C, cardHex on col D
sUser.Range(Cells(rS, 1)).Copy _
Destination:=sExceptions.Range(Cells(Count, 1))
sUser.Range(rS, 11).Copy _
Destination:=sExceptions.Range(Count, 2)
sFullExport.Range(rC, 1).Copy _
Destination:=sExceptions.Range(Count, 3)
sFullExport.Range(rC, 4).Copy _
Destination:=sExceptions.Range(Count, 4)
End If
Next
Count = 0
' To end settings to run faster
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Function
You're confusing Range and Cells.
Try
sUser.Cells(rs, 1).Copy _
Destination:=sExceptions.Cells(count, 1)
sUser.Cells(rs, 11).Copy _
Destination:=sExceptions.Cells(count, 2)
sFullExport.Cells(rC, 1).Copy _
Destination:=sExceptions.Cells(count, 3)
sFullExport.Cells(rC, 4).Copy _
Destination:=sExceptions.Cells(count, 4)
I need to create a sub to consolidate some data. I have several rows (anywhere from 4k to 20k) that I need to consolidate and sum the values from each column (from C to N).
The input data looks like this:
input
For the output, it should sum the columns for each SKU (Column A) and delete the rest.
Like this:
output
It should be simple enough, but I can’t seem to come up with an appropriate solution. I tried using an array with a scripting dictionary but I can’t figure out how to store more than a single value for each key. Sample (unfinished) code:
Dim sArray As Variant
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
sArray = Range(currentRange).Value
For i = 1 To UBound(sArray, 1)
For j = 3 To UBound(sArray, 2)
If dict.exists(sArray(i, 1)) = False Then
dict.Add sArray(i, 1), sArray(i, j)
Else
'this part is very wrong:
dict(sArray(i, 1)) = dict(sArray(i, j)) + sArray(i, j)
End If
Next
Next
Thank you very much in advance!
Try this, It sums the values in Column Q:AB then paste them back and removes the duplicates.
Sub dupremove()
Dim ws As Worksheet
Dim lastrow As Long
Set ws = Sheets("Sheet12") ' Change to your sheet
With ws
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("C2:N" & lastrow)
.Offset(, 14).FormulaR1C1 = "=SUMIF(C1,RC1,C[-14])"
.Value = .Offset(, 14).Value
.Offset(, 14).ClearContents
End With
With .Range("A1:N" & lastrow)
.Value = .Value
.RemoveDuplicates 1, xlYes
End With
End With
Before:
After:
I came up with the following solution instead and it took 30 seconds to run it (not entirely my own idea, borrowed some code from someplace else):
Sub dupes()
Dim MyRange As Range
Dim RowNum As Long
RowNum = 1
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set MyRange = Range("A2:N14200") 'for test only, on the real sub it's dynamic
MyRange.Sort key1:=Range("A2"), order1:=xlAscending
For Each Row In MyRange
With Cells
While Cells(RowNum, 1) = Cells(RowNum + 1, 1) And Cells(RowNum + 1, 1) <> "" 'very important the second condition or it will continue to loop forever
For i = 3 To 14
Cells(RowNum, i) = Cells(RowNum, i) + Cells(RowNum + 1, i)
Next
Rows(RowNum + 1).EntireRow.Delete
Wend
End With
RowNum = RowNum + 1
Next
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
It's kinda messy but it does the trick. Thanks to everyone!
Screen shot of what I want:
I want to time stamp each line as a change gets made so I can upload to a central file all lines that have been updated after a certain time. Since one asset might have multiple rows for each sub component, the user can fill in one line and autofill/copy paste to the relevant lines beneath. The rows might not be in a continuous range (e.g. when filtered).
The code I've got works great for changing one cell at a time and it works for a range but incredibly slowly.
This sub is called by worksheet_change shown in full below.
Sub SetDateRow(Target As Range, Col As String)
Dim TargetRng As Range
Dim LastCol, LastInputCol As Integer
With ActiveSheet
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column - 24
End With
For Each TargetRng In Target.Cells
If TargetRng.Cells.Count > 1 Then
Application.EnableEvents = True
Exit Sub
Else
Application.EnableEvents = False
Cells(TargetRng.Row, LastCol - 2) = Now()
Cells(TargetRng.Row, LastCol - 1).Value = Environ("username")
Cells(TargetRng.Row, LastCol).Value = Target.Address
End If
Next
Application.EnableEvents = True
End Sub
Target.Cells.Address returns the range (including non-visible cells), but I can't work out how to split this into individual, visible cells that I can loop through.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Errorcatch
Dim TargetRng As Range
Dim LastCol, LastInputCol, LastRow As Integer
Dim LastInputColLetter As String
Dim ContinueNewRow
With ActiveSheet
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column - 24
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
LastInputCol = LastCol - 3
If LastInputCol > 26 Then
LastInputColLetter = Chr(Int((LastInputCol - 1) / 26) + 64) & Chr(((LastInputCol - 1) Mod 26) + 65)
Else
LastInputColLetter = Chr(LastInputCol + 64)
End If
For Each TargetRng In Target.Cells
If TargetRng.Row <= 2 Then
Exit Sub
End If
If TargetRng.Column <= LastInputCol Then
SetDateRow Target, LastCol - 3
If TargetRng.Count = 1 Then
Application.EnableEvents = False
'
Dim cmt As String
' If Target.Value = "" Then
' Target.Value = " "
'
' End If
'----------------------------------------------------------------
If Intersect(TargetRng, Range("AC3:AC10000")) Is Nothing Then ' need to make column into variables in the code based on column name
Application.EnableEvents = True
Else
Application.EnableEvents = False
Cells(TargetRng.Row, "Z") = Now() 'Date booking was made column
Cells(TargetRng.Row, "AD").Value = Cells(Target.Row, "AD").Value + 1 ' iteration column
End If
'----------------------------------------------------------------
If TargetRng.Comment Is Nothing Then
cmt = Now & vbCrLf & Environ("UserName") & " *" & TargetRng.Value & "*"
Else
cmt = Now & vbCrLf & Environ("UserName") & " *" & TargetRng.Value & "* " & TargetRng.Comment.Text
End If
With TargetRng
.ClearComments
.AddComment cmt
End With
End If
End If
Application.EnableEvents = True
Next
Exit Sub
Errorcatch:
MsgBox Err.Description
Application.EnableEvents = True
End Sub
I have done some adjustments to your code (see comments within code)
This solution assumes the following:
Sample data has a two rows header and fields to be updated have the following titles located at row 1 (adjust corresponding lines in code if needed):
Date Change Made, Who Made Change and Last Cell Changed as per picture provided.
Booked Date, BkdDte Change and Iteration for columns AC, Z and AD respectively (this names are used for testing purposes, change code to actual names)
I have also combined both procedures into a common one in order to avoid the inefficient approach of looping twice the cells of the changed range. Let me know if they must remain separated and will do the necessary adjustments.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Wsh As Worksheet, rCll As Range
Dim iDteChn As Integer, iWhoChn As Integer, iLstCll As Integer
Dim iBkdDte As Integer, iBkdChn As Integer, iBkdCnt As Integer
Dim sCllCmt As String
Dim lRow As Long
On Error GoTo ErrorCatch
Rem Set Application Properties
Application.ScreenUpdating = False 'Improve performance
Application.EnableEvents = False 'Disable events at the begining
Rem Set Field Position - This will always returns Fields position
Set Wsh = Target.Worksheet
With Wsh
iDteChn = WorksheetFunction.Match("Date Change Made", .Rows(1), 0)
iWhoChn = WorksheetFunction.Match("Who Made Change", .Rows(1), 0)
iLstCll = WorksheetFunction.Match("Last Cell Changed", .Rows(1), 0)
iBkdDte = WorksheetFunction.Match("Booked Date", .Rows(1), 0) 'Column of field "Booked date" (i.e. Column `AC`)
iBkdChn = WorksheetFunction.Match("BkdDte Change", .Rows(1), 0) 'Column of field "Booked date changed" (i.e. Column `Z`)
iBkdCnt = WorksheetFunction.Match("Iteration", .Rows(1), 0) 'Column of field "Iteration" (i.e. Column `AD`)
End With
Rem Process Cells Changed
For Each rCll In Target.Cells
With rCll
lRow = .Row
Rem Exclude Header Rows
If lRow <= 2 Then GoTo NEXT_Cll
Rem Validate Field Changed
Select Case .Column
Case Is >= iLstCll: GoTo NEXT_Cll
Case iDteChn, iWhoChn, iBkdChn, iBkdCnt: GoTo NEXT_Cll
Case iBkdDte
Rem Booked Date - Set Count
Wsh.Cells(lRow, iBkdChn) = Now()
Wsh.Cells(lRow, iBkdCnt).Value = Cells(.Row, iBkdCnt).Value + 1
End Select
Rem Update Cell Change Details
Wsh.Cells(lRow, iDteChn).Value = Now()
Wsh.Cells(lRow, iWhoChn).Value = Environ("username")
Wsh.Cells(lRow, iLstCll).Value = .Address
Rem Update Cell Change Comments
sCllCmt = Now & vbCrLf & Environ("UserName") & " *" & .Value & "*"
If Not .Comment Is Nothing Then sCllCmt = sCllCmt & .Comment.Text
.ClearComments
.AddComment sCllCmt
End With
NEXT_Cll:
Next
Rem Restate Application Properties
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
ErrorCatch:
MsgBox Err.Description
Rem Restate Application Properties
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Do let me know of any questions you might have about the resources used in this procedure.
You could use something like this:
Sub SetDateRow(Target As Range, Col As String)
Dim TargetRng As Range
Dim LastCol As Long
Dim LastInputCol As Long
Dim bEvents As Boolean
With ActiveSheet
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column - 24
End With
bEvents = Application.EnableEvents
Application.EnableEvents = False
If Target.Cells.Count > 1 Then
For Each TargetRng In Target.SpecialCells(xlCellTypeVisible).Areas
Cells(TargetRng.Row, LastCol - 2).Resize(TargetRng.Rows.Count, 1).Value = Now()
Cells(TargetRng.Row, LastCol - 1).Resize(TargetRng.Rows.Count, 1).Value = Environ("username")
Cells(TargetRng.Row, LastCol).Resize(TargetRng.Rows.Count, 1).Value = Target.Address
Next
Else
Cells(Target.Row, LastCol - 2).Value = Now()
Cells(Target.Row, LastCol - 1).Value = Environ("username")
Cells(Target.Row, LastCol).Value = Target.Address
End If
Application.EnableEvents = bEvents
End Sub
but make sure you call it before or after the loop in your change event, not inside it as you are now!
I have hit a roadblock trying to think through how I might write the VBA code that counts the number of unique order numbers and and whether the order status is open or closed for each salesperson.
I am working on writing the VBA that would affect Sheet2. I need the VBA to loop through Sheets("Sheet2").Range("A:A") and (1) lookup the name in Sheet1; (2a) count the unique order numbers that correspond with the salesperson's name and are "Open" and (2b) count the unique order numbers that correspond with the salesperson's name and are "Closed". I have designed "?"s for the values I am looking to calculate with the macro and included the answer numbers.
Any help is greatly appreciated. Please let me know if I can clarify anything.
Sheet1 - Orders
Sheet2 - Orders Summary
A B C
1 **Name** **Count-Uniq Open Orders** **Count-Uniq Closed Orders**
2 John ? (answer: 2) ? (answer: 0)
3 Ben ? (answer: 1) ? (answer: 1)
4 Fred ? (answer: 1) ? (answer: 0)
Tested:
Sub Tester()
Dim d1, d2, arrIn, r, tmp, nm, id, i
Dim c, k
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
With Sheets("orders")
arrIn = .Range(.Range("A2"), _
Cells(Rows.Count, 3).End(xlUp)).Value
End With
For r = 1 To UBound(arrIn, 1)
nm = arrIn(r, 1) 'name
id = arrIn(r, 2) 'order #
If Not d1.exists(nm) Then
d1.Add nm, Array(0, 0)
End If
If Not d2.exists(id) Then
tmp = d1(nm)
i = IIf(UCase(arrIn(r, 3)) = "OPEN", 0, 1)
tmp(i) = tmp(i) + 1
d1(nm) = tmp
d2.Add id, 0
End If
Next r
Set c = Sheets("summary").Range("a2")
For Each k In d1.keys
c.Resize(1, 3).Value = Array(k, d1(k)(0), d1(k)(1))
Set c = c.Offset(1, 0)
Next k
End Sub
Try this one :)
Sub Macro1()
Dim ws1 As Worksheet, ws2 As Worksheet, wsTemp As Worksheet
Dim rng As Range
Dim myformula1 As String, myformula2 As String
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
Set ws1 = ThisWorkbook.Sheets("Sheet1") 'where you have your Orders
Set ws2 = ThisWorkbook.Sheets("Sheet2") 'where you have your summary which should have names in it
ws1.Copy ThisWorkbook.Sheets(1)
Set wsTemp = ActiveSheet: wsTemp.Name = "Temp"
With wsTemp
Set rng = .UsedRange
rng.RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
End With
myformula1 = "=COUNTIFS(" & wsTemp.Name & "!A:A,A2," & wsTemp.Name & "!C:C,""Open"")"
myformula2 = "=COUNTIFS(" & wsTemp.Name & "!A:A,A2," & wsTemp.Name & "!C:C,""Closed"")"
With ws2.Range(ws2.Range("A2"), ws2.Range("A" & ws2.Rows.Count).End(xlUp))
.Offset(0, 1).Formula = myformula1
.Offset(0, 2).Formula = myformula2
.Offset(0, 1).Resize(, 2).Value = .Offset(0, 1).Resize(, 2).Value
End With
wsTemp.Delete
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
No loop. Just to give you an alternative :D
Hope this helps in any way.
In cell B2 of sheet 2:
=SUM(IF(FREQUENCY(IF(Sheet1!$A$2:$A$10=$A2,IF(Sheet1!$C$2:$C$10=B$1,Sheet1!$B$2:$B$10)),IF(Sheet1!$A$2:$A$10=$A2,IF(Sheet1!$C$2:$C$10=B$1,Sheet1!$B$2:$B$10)))>0,1))
This is an array formula so to confirmit hold Ctrl + Shift and hit Enter, this will add a { and } at start and end respectively.
In cell C3:
=SUM(IF(FREQUENCY(IF(Sheet1!$A$2:$A$10=$A2,IF(Sheet1!$C$2:$C$10=C$1,Sheet1!$B$2:$B$10)),IF(Sheet1!$A$2:$A$10=$A2,IF(Sheet1!$C$2:$C$10=C$1,Sheet1!$B$2:$B$10)))>0,1))
Same again, it's an array so Ctrl+Shift and Enter
And then copy the formulae down.
Just as an alternative, in terms of a pivot table solution the following answer covers the techniques required:
Simple Pivot Table to Count Unique Values