VBA copy and past values in location based off other values - excel

I'm just learning how to do VBA in excell and I need some help. I have been searching this site but have not found an example that I could tweak that solves my needs (or at least what I could understand). I am trying to make a button that archives data. I have 2 sheets where one is for user input and the other is the archived location. I would like to have excell take the value in column C and past it in the matching location in sheet 2 based on the valves of sheet 1's values in column A and B.
Sheet 1
A _______ B______C (user inputed value)
Item 1 ___Date ___ 5
Item 2 ___Date ___ 8
Item 3 ___Date ___ 2
Sheet 2 (archive sheet)
A ______ B _________ C _______ D
_______Item 1 ___ Item 2 ____ Item 3
Date
Date
Date
I was using a method of just copying the sheet 1 data on a 3rd sheet and running a vlookup but if the user archived the same date twice it would only get the value of the most recent archive. Im not sure how loops work but what I found on other peoples requests I think something like that may be helpful.
Any insight would be most appreciated.

If you do not know how loops work, you must learn the basics of Excel VBA. You cannot hope to stitch together bits of code gathered from the internet without some understanding of VBA.
Search for "Excel VBA Tutorial". You will get many hits of which many will be for free online tutorials. These tutorials differ in approach so try a few to see which best matches your learning style. Alternatively, visit a good bookshop or library where you will find a selection of Excel VBA Primers. I suggest a library so you can take a few books home for a try before purchasing your favourite.
There are many holes in your specification. Perhaps you have a complete specification which you have not documented here. If you have a complete specification, please do not add it to your question. For sites like this, you need small focused questions.
Two design questions I have spotted are:
Why fill the Date column with =TODAY()? If the archive macro is not run at the end of the day, Excel will have changed the date when the macro is run the next day. Either fill the column with the date value or use the nearest VBA equivalent function which is Now().
You imply the user might enter a count for Item A and then enter another count later in the day. The archive sheet is to hold the total of those two counts. How is this handled? You could have two or more rows for Item A. The user could run the archive macro before entering a new value in the Item A row. You could use a Worksheet Change event to automatically archive the value after the user has entered it.
You need to fully specify what the macro is going to do and how it is going to be used before trying to code it. Below I have provided two alternative macros that achieve what I believe is the first step of your requirement: locate valid rows in the data entry worksheet and extract the values ready for achiving.
I suggest you study basic Excel VBA first. That should give you enough knowledge to understand my macros even though the second macro uses non-basic statements. Come back with questions as necessary but please run and try to understand the macros before asking these questions.
Demo1
I created a worksheet "Data Entry" and filled it with data that matches my understanding of your worksheet "Sheet1". Please do not use the default worksheet names because it gets very confusing. Replace my name with whatever you choose.
The macro Demo1 outputs the values from valid rows to the Immediate Window. Writing to the Immediate Window is a convenient way of testing small blocks of code as they are written.
I have documented what the code does but not the VBA statements. Once you know a statement exists, it is usually easy to look it up.
Option Explicit
Sub Demo1()
Dim CountCrnt As Long
Dim DateCrnt As Date
Dim ItemCrnt As String
Dim RowCrnt As Long
Dim RowLast As Long
With Worksheets("Data Entry")
' This sets RowLast to the last used row in column "C" or sets it to 1 if no
' row is used. It is the VBA equivalent of positioning the cursor to the
' bottom of column C and clicking Ctrl+Up
RowLast = .Cells(Rows.Count, "C").End(xlUp).Row
' I have assumed the first data row is 2
For RowCrnt = 2 To RowLast
' I have allowed for column C being empty. I assume such rows are
' to be ignored. I also ignore rows with invalid values in columns
' B or C.
If .Cells(RowCrnt, "C").Value <> "" And _
IsNumeric(.Cells(RowCrnt, "C").Value) And _
IsDate(.Cells(RowCrnt, "B").Value) Then
' Extract the validated values to variables ready for the next stage
' of processing.
ItemCrnt = .Cells(RowCrnt, "A").Value
DateCrnt = .Cells(RowCrnt, "B").Value
CountCrnt = .Cells(RowCrnt, "C").Value
' Output row values to Immediate Window
Debug.Print RowCrnt & " " & ItemCrnt & " " & _
Format(DateCrnt, "dmmmyy") & " " & CountCrnt
End If
Next
End With
End Sub
Demo2
Macro Demo2 achieves the same as macro Demo1 but in a different way.
Demo1 accessed the cells within the worksheet individually. Demo2 copies the entire
worksheet to a Variant which can then be accessed as a 2D array. This is much faster that individual cell access and is usually more convenient if you only want the cell values.
Demo1 output values to the Immediate Window. This is very convenient for small volumes of output but early lines will be lost for larger volumes. Demo2 creates a file within the same folder as the workbook and writes the output to that file so nothing will be lost.
Sub Demo2()
Dim CountCrnt As Long
Dim DateCrnt As Date
Dim FileOutNum As Long
Dim ItemCrnt As String
Dim RowCrnt As Long
Dim RowLast As Long
Dim SheetValue As Variant
FileOutNum = FreeFile
Open ActiveWorkbook.Path & "\Demo2.txt" For Output As #FileOutNum
With Worksheets("Data Entry")
' This statement converts Variant SheetValue to an appropriately sized
' two-dimensional array and copies the values from the entire used
' range of the worksheet to it.
SheetValue = .UsedRange.Value
' Standard practice for 2D arrays is to have the first dimension for
' columns and the second for rows. For arrays copied from or to
' worksheets, the first dimension is for rows and the second is for
' columns. This can be confusing but means that array elements are
' accessed as SheetValue(Row, Column) which matches Cells(Row, Column).
' Note that the lower bounds for both dimensions are always one. If the
' range copied from the worksheet starts at Cell A1, row and column
' numbers for the array will match those of the worksheet.
End With
For RowCrnt = 2 To UBound(SheetValue, 1)
' I have allowed for column 3 (= "C") being empty. I assume such rows
' are to be ignored. I also ignore rows with invalid values in columns
' 2 (= "B") or 3.
If SheetValue(RowCrnt, 3) <> "" And _
IsNumeric(SheetValue(RowCrnt, 3)) And _
IsDate(SheetValue(RowCrnt, 2)) Then
ItemCrnt = SheetValue(RowCrnt, 1)
DateCrnt = SheetValue(RowCrnt, 2)
CountCrnt = SheetValue(RowCrnt, 3)
' Output row values to file
Print #FileOutNum, RowCrnt & " " & ItemCrnt & " " & _
Format(DateCrnt, "dmmmyy") & " " & CountCrnt
End If
Next
Close #FileOutNum
End Sub
Edit New section in response to supplementary question.
As you have discovered there is no way of "printing" to a worksheet but it is easy to write to individual cells. I have used a diagnostic worksheet but I normally consider this technique more trouble than it is worth. Output to a file is easier to add and easier to delete and it does not interfere with the code.
The code below is in the correct order but I have added explanations between blocks.
Dim RowDiagCrnt As Long
The above statement is not within a subroutine which makes is a gloabl variable that can be accessed from any routine. If there are several routines that need to output diagnostic information, it is easier to use a global variable for the row number than pass it as a parameter from the parent routine.
I have a system for naming variables, "Row" means this is a row. "Diag" identifies the worksheet". "Crnt" identifies this as the current row number. In Demo1, I had RowCrnt because I only had one worksheet. You may not like my system. Fine, develop your own. Having a system means I can look at a macro I wrote years ago and know what all the variables are. This makes maintenance much, much easier.
Sub Demo3()
Dim CountCrnt As Long
Dim DateCrnt As Date
Dim ItemCrnt As String
Dim RowDiagCrnt As Long
Dim RowEntryCrnt As Long
Dim RowEntryLast As Long
Dim ValidRow As Boolean
Dim WkshtDiag As Worksheet
Dim WkshtEntry As Worksheet
I now have two worksheets and I will have to switch between them. I do not like multiple uses of Worksheets("Xxxxx") because I might change "Xxxxx". A reference avoids multiple uses of the name and is faster.
Set WkshtEntry = Worksheets("Data Entry")
Set WkshtDiag = Worksheets("Diagnostics")
' Delete existing contents of diagnostic worksheet and create header row
With WkshtDiag
.Cells.EntireRow.Delete
.Cells(1, "A").Value = "Row"
.Cells(1, "B").Value = "Item"
.Cells(1, "C").Value = "Date"
.Cells(1, "D").Value = "Count"
End With
RowDiagCrnt = 2
With WkshtEntry
RowEntryLast = .Cells(Rows.Count, "C").End(xlUp).Row
End With
For RowEntryCrnt = 2 To RowEntryLast
I must keep the access to the two worksheet separate if I want to use With statements. I have used a boolean to handle this problem.
With WkshtEntry
If .Cells(RowEntryCrnt, "C").Value <> "" And _
IsNumeric(.Cells(RowEntryCrnt, "C").Value) And _
IsDate(.Cells(RowEntryCrnt, "B").Value) Then
ItemCrnt = .Cells(RowEntryCrnt, "A").Value
DateCrnt = .Cells(RowEntryCrnt, "B").Value
CountCrnt = .Cells(RowEntryCrnt, "C").Value
ValidRow = True
Else
ValidRow = False
End If
End With
If ValidRow Then
With WkshtDiag
' Output row values to Diagnostic worksheet
.Cells(RowDiagCrnt, "A").Value = RowEntryCrnt
.Cells(RowDiagCrnt, "B").Value = ItemCrnt
With .Cells(RowDiagCrnt, "C")
.Value = DateCrnt
.NumberFormat = "dmmmyy"
End With
.Cells(RowDiagCrnt, "D").Value = CountCrnt
RowDiagCrnt = RowDiagCrnt + 1
End With
End If
Next
' Set columns to appropriate width for contents
With WkshtDiag
.Columns.AutoFit
End With
End Sub
I hope you can see why the reasons for all the changes I made to Demo1 to create Demo3. Having a second worksheet that is not required for the final solution adds complexity that I normally prefer to avoid.

Related

Finding cells that do not match a predefined specific pattern in Excel using VBA

Am trying to make a VBA validation sheet on Excel to find all the cells that do not match a predefined pattern and copy it to another sheet
My pattern is "4 numbers/5 numbers"
Ex: 1234/12345 is accepted
2062/67943 is accepted
372/13333 is not accepted
1234/1234 is not accepted etc...
I tried to put the following in the conditions sheet : <>****/***** and <>????/????? and both did not work (am not sure about the correctness of the approach as am still a beginner in VBA)
For the code itself, this is what I wrote :
Sub GuaranteeElig()
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = SheetName
Sheets("MainSheet").UsedRange.AdvancedFilter Action:= _
xlFilterCopy,
CriteriaRange:=Sheets("ConditionsSheet").Range("B1:B2"), _
CopyToRange:=Range("A1"), Unique:=False
End Sub
Any tips on how I can do it ?
Thanks in advance :)
As long as the values of the numbers are independent and do not matter, and it is only the Length of the numerical strings that count, you could use a for loop on the cells from the "search" sheet (I assume this is the MainSheet as shown in your code?) where your values are contained.
From there, I'll give you a couple ways to place the data in the validation sheet (assuming this is your ConditionsSheet as shown in your code?) where you are trying to pinpoint the values.
(You may need to change part of your approach depending on how you want the incorrect set of values laid out on your secondary sheet - but this should get you started.) I added a TON of comments as you say you're new to VBA - these will help you understand what is being done.
Sub GuaranteeElig()
'Adding this to help with performance:
Application.ScreenUpdating = False
'Assuming you are adding a sheet here to work with your found criteria.
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "ConditionsSheet"
'Using the naming bits below I am assuming the data you are searching for is on MainSheet
'Get used range (most accurate and efficient way I have found yet, others on S.O.
'may have better ways for this - research it if this does not work for you)
'I have had problems using the Sheets().UsedRange method.
Dim c as Long 'This may not be necessary for you if you are looping through only column "A"
Dim r as Long
'Cells(y,x) method uses numerical values for each row (y) or column (x).
c = Cells(1, Columns.Count).End(xlToLeft).Column 'May not be necessary depending on your needs.
'Using this because you have "UsedRange" in your
'code.
'.End(xlToLeft) signifies we are going to the end of the available cell range of
'Row 1 and then performing a "Ctrl+Left Arrow" to skip all blank cells until we hit
'the first non-blank cell.
r = Cells(Rows.Count, 1).End(xlUp).Row
'.End(xlUp) method is similar - we go to the end of the available cell range for the
'column ("A" in this case), then performing a "Ctrl+Up Arrow" to skip all blank cells.
'If you have a header row which spans across the sheet, this is your best option,
'unless you have 'helper' cells which extend beyond the final column of this header
'row. I am assuming Row 1 is a header in this case - change to your needs.
'For your Rows - choose the column which contains congruent data to the bottom of
'your used range - I will assume column 1 in this case - change to suit your needs.
Dim i as long
Dim j as integer
Dim cel as Range
Dim working_Str() as String 'String Array to use later
Dim string1 as String
Dim string2 as String
Dim badString as Boolean
For i = 2 to r Step 1 'Step down from row 2 to the end of data 1 Row at a time
'Row 1 is header.
set cel=Cells(i, 1) 'Sets the cell to check - assuming data is in Column "A"
'i will change from for loop so 'cel' changes from "A2555"
'to "A2554" to "A2553" etc.
working_Str=Split(cel.Value, "/", -1) 'Splits the value based on "/" inside of cel
string1=working_Str(0) 'what we hope will always be 4 digits
string2=working_Str(1) 'what we hope will always be 5 digits
If Len(string1)<>4 Then 'string1 _(xxxx)_(/)(don't care) does not equal 4 digits in length
badString = True
Elseif Len(string2)<>5 Then ''string1 (don't care)(/)_(xxxxx)_ does not equal 5 digits in length
badString = True
End If
If badString Then 'If either strings above were not correct length, then
'We will copy cell value over to the new sheet "ConditionsSheet"
'Comment the next 2 commands to change from going to one row at a time to
'Matching same row/Cell on the 2nd sheet. Change to suit your needs.
j = j + 1 'Counter to move through the cells as you go, only moving one cell
'at a time as you find incorrect values.
Sheets("ConditionsSheet").Range("A" & j).Value=cel.Value 'sets the value on other sheet
'UNComment the next command to change from going to one row at a time to
'matching same row/cell on the 2nd sheet. Change to suit your needs.
'Sheets("ConditionsSheet").Range("A" & i).Value=cel.Value
End if
badString = False 'resets your boolean so it will not fail next check if strings are correct
Next i
'Returning ScreenUpdating back to True to prevent Excel from suppressing screen updates
Application.ScreenUpdating = True
End Sub
UPDATE
Check the beginning and ending lines I just added into the subroutine. Application.ScreenUpdating will suppress or show the changes as they happen - suppressing them makes it go MUCH quicker. You also do not want to leave this setting disabled, as it will prevent Excel from showing updates as you try to work in the cell (like editing cell values, scrolling etc. . . Learned the hard way. . .)
Also, if you have a lot of records in the given row, you could try putting the data into an array first. There is a great example here at this StackOverflow Article.
Accessing the values of a range across multiple rows takes a LOT of bandwidth, so porting the range into an Array first will make this go much quicker, but it still may take a bit. Additionally, how you access the array information will be a little different, but it'll make sense as you research it a little more.
Alternative To VBA
If you want to try using a formula instead, you can use this - just modify for the range you are looking to search. This will potentially take longer depending on processing speed. I am entering the formula on 'Sheet2' and accessing 'Sheet1'
=IF(COUNTIF(Sheet1!A1,"????/?????"),1,0)
You are spot on with the search pattern you want to use, you just need to use a function which uses wildcard characters within an "if" function. What you do with the "If value is true" vs "If value is false" bits are up to you. COUNTIF will parse wildcards, so if it is able to "count" the cell matching this string combination, it will result in a "True" value for your if statement.
Regex method, this will dump the mismatched value in a worksheet named Result, change the input range and worksheet name accordingly.
In my testing, 72k cells in UsedRange takes about 4seconds~:
Option Explicit
Sub GuaranteeElig()
Const outputSheetName As String = "Result"
Dim testValues As Variant
testValues = ThisWorkbook.Worksheets("MainSheet").UsedRange.Value 'Input Range, change accordingly
Const numPattern As String = "[\d]{4}\/[\d]{5}"
Dim regex As Object
Set regex = CreateObject("VBScript.Regexp")
regex.Pattern = numPattern
Dim i As Long
Dim n As Long
Dim failValues As Collection
Set failValues = New Collection
'Loop through all the values and test if it fits the regex pattern - 4 digits + / + 5 digits
'Add the value to failValues collection if it fails the test.
For i = LBound(testValues, 1) To UBound(testValues, 1)
For n = LBound(testValues, 2) To UBound(testValues, 2)
If Not regex.Test(testValues(i, n)) Then failValues.Add testValues(i, n)
Next n
Next i
Erase testValues
Set regex = Nothing
If failValues.Count <> 0 Then
'If there are mismatched value(s) found
'Tranfer the values to an array for easy output later
Dim outputArr() As String
ReDim outputArr(1 To failValues.Count, 1 To 1) As String
For i = 1 To failValues.Count
outputArr(i, 1) = failValues(i)
Next i
'Test if output worksheet exist
Dim outputWS As Worksheet
On Error Resume Next
Set outputWS = ThisWorkbook.Worksheets(outputSheetName)
On Error GoTo 0
'If output worksheet doesn't exist, create a new sheet else clear the first column for array dump
If outputWS Is Nothing Then
Set outputWS = ThisWorkbook.Worksheets.Add
outputWS.Name = outputSheetName
Else
outputWS.Columns(1).Clear
End If
'Dump the array starting from cell A1
outputWS.Cells(1, 1).Resize(UBound(outputArr, 1)).Value = outputArr
Else
MsgBox "No mismatched value found in range"
End If
Set failValues = Nothing
End Sub
If you do not need duplicate values in the list of mismatched (i.e. unique values) then sound out in the comment.

Excel Macro check if cell is empty and search specific word in column

Guy, I am beginner for VBA language, and I have a question to stuck on it.
How to make a macro script to check if ANY rows of column B is input word of "C" AND ANY rows of column C is empty, then it will trigger to highlight this row with color and prompt up the message box to remind user to correct it.
Also, the column D is using the formula and cell by cell method to check the above requirement.
=IF(ISBLANK(B4),"",IF(OR(B4="C",B4="O"),IF(AND(B4="C", ISBLANK(C4)),"WARNING: Case Closed! Please Write Down Resolution!",""),"ERROR: Invalid Value - Status! Please Input The Right Value!"))
For example, the row 4 meet up requirement and affected.
Is there way to do so?
Please help. Thanks.
UPDATE:Thanks Variatus!
When I save the file, it prompt up this message box. What can I do? Thanks.
Macro Screen
Error
Under normal circumstances you would be asked to show more of an own effort before receiving help on this forum, including from me. But apparently circumstances aren't normal. So, here we go. Paste this procedure to a standard code module (it's name would be a variation of Module1 by default).
Option Explicit
Sub MarkErrors()
' 283
Dim Spike() As String
Dim i As Long ' index of Spike
Dim Rl As Long ' last used row
Dim R As Long ' loop counter: rows
Application.ScreenUpdating = False
With Sheet1 ' this is the sheet's CodeName (change to suit)
.UsedRange.Interior.Pattern = xlNone ' remove all existing highlights
Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
ReDim Spike(1 To Rl)
For R = 2 To Rl
If Trim(.Cells(R, "B").Value) = "C" Then
If IsEmpty(.Cells(R, "C")) Then
.Range(.Cells(R, "A"), .Cells(R, "D")).Interior.Color = vbYellow
i = i + 1
Spike(i) = "Row " & R
End If
End If
Next R
End With
Application.ScreenUpdating = True
If i Then
ReDim Preserve Spike(1 To i)
MsgBox "Status errors were found in the following entries:-" & vbCr & _
Join(Spike, "," & vbCr), vbInformation, "Corrections required"
End If
End Sub
Pay attention to the specified worksheet Sheet1. This is a CodeName, and it is a default. Excel will create a sheet by that name when you create a workbook. The CodeName doesn't change when the user changes the tab name but you can change it in the VB Editor. It's the (Name) property of the worksheet.
Install the procedure below in the code sheet of Sheet1 (not a standard code module and therefore not the same as where you installed the above code. This module is created by Excel for each sheet in every workbook. Use the existing one.
Private Sub Worksheet_Activate()
' 283
MarkErrors
End Sub
This is an event procedure. It will run automatically whenever Sheet1 is activated (selected). So, under normal circumstances you shouldn't ever need to run the first procedure manually. But I've already talked about circumstances. They aren't always normal. :-)

How to loop through columns in VBA given that columns are referred by a letter? [duplicate]

This question already has answers here:
Excel VBA, getting range from an inactive sheet
(3 answers)
Closed 1 year ago.
I am a newbie to the VBA world and need your help.
I want to copy data from columns A, B and C in Sheet2 and Sheet3 and paste it in Columns A, B and C of Sheet1 but stacked. Meaning, data from Sheet2 should be pasted in "A1:A4", then data from Sheet3 should be pasted in "A5:A9".
I am using the following code and getting an error:
j = 1
For i = 1 to 2
For k = 1 to 3
Sheets(i+1).range(cells(1,k),cells(4,k).copy
Sheet(1).range(cells(j,k),cells(j+3,k).PasteSpecial xlPasteValues
Next k
j = j + 4
next i
If there is a better way to do it, it would be helpful too.
Please help!
The difference between your code and the one submitted below is in the effort expanded on preparation. Preparation led to recognition of problems where lack of preparation led to confusion and, ultimately, this question. What I'm saying is that I don't think you would have needed to ask had you known to prepare adequately.
Private Sub Snippet()
' 218
Dim Ws(1 To 2) As Worksheet ' "Source 1" and "Source 2"
Dim i As Integer ' loop counter: Ws index
Dim Rs As Long ' loop counter: rows (source)
Dim WsOut As Worksheet ' "Output"
Dim Rt As Long ' target row
With ThisWorkbook
Set WsOut = .Worksheets("Output")
Set Ws(1) = .Worksheets("Source 1")
Set Ws(2) = .Worksheets("Source 2")
End With
With WsOut ' = last used row in WsOut
Rt = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Application.ScreenUpdating = False
For i = 1 To 2 ' loop through Ws(1 to 2)
With Ws(i) ' find last used row in Ws(1)
' start copying from row 2 because row 1 probably holds captions
' end with last used row in column A
For Rs = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
Rt = Rt + 1
.Range(.Cells(Rs, 1), .Cells(Rs, 3)).Copy
WsOut.Cells(Rt, 1).PasteSpecial xlPasteValues
Next Rs
End With
Next i
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
End Sub
The procedure starts off by naming all variables. The first result was to replace references like "Sheet(1)" even at this early stage because "Sheet(1)" is the first sheet from the left in the tab bar. If you add a sheet unwittingly your code won't work anymore or, rather, it will destroy your workbook. Your variables "k" and "j" were replaced with "Rs" and "Rt" marking them as row numbers (source and target).
Next, the code makes sure that the worksheets are properly defined as being within ThisWorkbook. They are also properly linked to their real life names, executing a decision made at the beginning. Actually, the variable declarations are modified many times while the rest of the code is developed. It isn't hewn in stone at the beginning but everything is built on it nevertheless.
Then the Target Row is set, and a system for it's maintenance designed. The system is to find the last used row first and then increment that number every time before a new row is written.
The decision is made to turn off ScreenUpdating while the code runs. It will run faster that way but you must make provision to turn the feature back on at the end. That part of the code is written at this time.
And only now I arrive at the point which you had started out with. My code is remarkably like yours. Note that Copy/PasteSpecial allows you to choose what to paste, in this case "Values". You might use Copy with Destination instead which would also include formats. Or you might specify to copy formulas instead of values. To copy values you could simply use syntax like WsOut.Cells(Rt, 1).Value = .Cells(Rs, 1).Value` in a little loop. Because of the solid fundament on which this code is built it's very easy to modify these two lines using the established components.
The code ends on setting Application.CutCopyMode = False and presenting the result of the action in the display by restoring ScreenUpdating.

Copy (Named) Table multiple times within the same sheet and change the tables names

I'm building a project management spreadsheet where multiple teams are going to have a copy. I want to create a simple address book. I have the names of the teams in a table and using VBA, I create the Master Table.
In the range B4:D5 there is a simple table with three column names:
Name
Telephone
Email
I have named this table (in Name Manager) as ContactTeam1
I want to copy and paste this exact 3x2 table to be below each corresponding team such as the image Here and change each Named Table as ContactTeam2, ContactTeam3 and so on.
The reason I want to use VBA is because, we have many different projects, so I want to automate the process as much as I can, for future projects as well.
I will fill in the tables with all the necessary information (Names,Phones,Emails) - by hand. The reason I want to use tables is that it has the benefit to auto-expand to include any new lines below the last.
As a bonus functionality, when somebody clicks the cell on top that contains the name of the Team. (Team Blue, Team Red etc.) all the emails of the corresponding range will be copied to clipboard, to be used in an email client. (This can be done easier with tables - one more reason I want to use them).
I hope this helps
Sub Bouton()
Dim cell As Range
Dim rng As Range
Dim cnt As Integer
Dim RangeName As String
Dim CellAdd1, CellAdd2 As String
For cnt = 2 To ActiveSheet.Range("NumberTimes")
Set rng = Range("ContactTeam" & (cnt - 1))
RangeName = "ContactTeam" & cnt
CellAdd1 = Cells(rng.Row, rng.Column + 3).Address
CellAdd2 = Cells(rng.Row + 1, rng.Column + 5).Address
'+ 1 in the row so the named range goes from B4 to D5
Set cell = ActiveSheet.Range(CellAdd1, CellAdd2)
ThisWorkbook.Names.Add Name:=RangeName, RefersTo:=cell
Range("ContactTeam1").Copy Range("ContactTeam" & cnt)
Next cnt
End Sub
I'm not the best in VBA, but what this does is that it creates a new range each 3 cells and names it from ContactTeam2 to whatever your limit is. I created a named range called NumberTimes. Basically, you tell it how many new ranges you want to be created.
easiest of all, i guess we can use dictionary here. would be faster but here he what i tested/tried , EXACTLY on your data and works.
Sub d()
Sheet1.Select
Range("b3").Select
Do
Range("b3:d4").Name = "mainteam"
ActiveCell.Offset(0, 3).Select
Range("mainteam").Copy ActiveCell
Range(ActiveCell, ActiveCell.End(xlDown).End(xlToRight)).Select
Range(ActiveCell, ActiveCell.End(xlDown).End(xlToRight)).Name = "team" & i
i = i + 1
Loop While i <> 5
End Sub

Optimizing Excel CountIfs - can I make it go faster?

I have some larger files I need to validate the data in. I have most of it automated to input the formulas I need automatically. This helps eliminate errors of copy and paste on large files. The problem is with this latest validation.
One of the latest validations involves counting the number of rows that match 3 columns. The 3 columns are in Sheet 2 and the rows to count are in Sheet 1. Then compare this count with an expected number based on Sheet 2. It is easy enough to do with CountIFs, but there are large files and it can take up to an hour on some of them. I am trying to find something faster.
I am using a smaller file and it is still taking about 1 minute. There are only about 1800 rows.
I have something like this:
In Check1 I am using: =COUNTIFS(Sheet1!A:A,A2,Sheet1!B:B,B2,Sheet1!C:C,C2)
My code puts that formula in the active cell. Is there a better way to do this?
Is there anyway - using VB or anything - to improve the performance.
When the rows start getting into the 10's of thousands it is time to start this and get lunch. And, then hope it is done when I get back to my desk!
Thanks.
You basically have to iterate over all rows for each column, this is expensive. You might be able to split this into two tasks:
Merge your Columns A-C into one value =CONCAT(A2,B2,C2)
Then do only a single countif on this column =COUNTIF(D:D,D2)
That way you get rid of two (time) expensive countifs at the cost of the new concat.
You should narrow the range CountIf acts on from entire columns to the actual used range
And your code could write the result of the formula instead of the formula itself
Like follows:
With Sheet1
Set sheet1Rng = Intersect(.UsedRange, .Range("A:C"))
End With
With Sheet2
For Each cell in Intersect(.UsedRange, .Range("A:A"))
cell.Offset(,3) = WorksheetFunction.CountIfs(sheet1Rng.Columns(1), cell.Value, sheet1Rng.Columns(2), cell.Offset(,1).Value, sheet1Rng.Columns(3),cell.Offset(2).Value)
Next cell
End With
I set up a mock sheet, using a layout similar to what you show, with 10,000 rows, and manually filled it with the COUNTIFS formula you show. Changing a single item in the data triggered a recalculation which took about ten seconds or so to execute.
I then tried the following macro, which executed in well under one second. All of the counting is done within the VBA macro. So this Dictionary method may be an answer to your speed problems.
Before running this, you may want to set the Calculation state to Manual (or do it in the code) if you have COUNTIFS on the worksheet.
Option Explicit
'set reference to Microsoft Scripting Runtime
Sub CountCol123()
Dim DCT As Dictionary
Dim V As Variant
Dim WS As Worksheet, R As Range
Dim I As Long
Dim sKey As String
Set WS = Worksheets("sheet2")
'read the info into an array
With WS
Set R = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=4)
V = R
End With
'Get count of the matches
Set DCT = New Dictionary
For I = 2 To UBound(V, 1)
sKey = V(I, 1) & "|" & V(I, 2) & "|" & V(I, 3)
If DCT.Exists(sKey) Then
DCT(sKey) = DCT(sKey) + 1
Else
DCT.Add Key:=sKey, Item:=1
End If
Next I
'Get the results and write them out
For I = 2 To UBound(V, 1)
sKey = V(I, 1) & "|" & V(I, 2) & "|" & V(I, 3)
V(I, 4) = DCT(sKey)
Next I
'If you have COUNTIFS on the worksheet when testing this,
' or any other formulas that will be triggered,
' then uncomment the next line
'Application.Calculation = xlCalculationManual
With R
.EntireColumn.Clear
.Value = V
End With
End Sub
The Excel alternative named Cell in Hancom Office 2020 is insanely fast at countifs. Not sure why. On my i7-5775C, Excel 2019 takes 90 seconds for a countifs with two criteria for populating 10,000 rows with the results. Using Cell, the exact same operation completes in less than 28 seconds. I have verified that the results match those generated by Excel 2019.

Resources