I am working with a workbook that currently has 3 sheets. The first sheet is an overview where the filtered data will appear. Cell D11 has the color that I am looking for. Upon entering the color cells F3:I27 Populate with information like color, shape, number and animal.
C2C-Tracker2
I would use a Pivot Table for this, however, I have another set of data in K3:M27. This data is pulled from another sheet within the workbook with a similar function.
The formula that I am using is:
=IFERROR(INDEX(cases!A:A,SMALL(IF(EXACT($D$3,cases!$C:$C),ROW(cases!$C:$C)-ROW($F$1)+1),ROW(1:1))),"")
Of course it is entered using CTRL + SHIFT + ENTER for it to work properly.
I tried using a VBA Macro that I pulled from the video below:
Excel VBA Loop to Find Records Matching Search Criteria
So many array formulas can really make your workbook very slow.
Here is a code to populate Dataset1 using arrays. It runs in less than a second.
Hope this gets you started. I have commented the code but if you still have a problem understanding, just post back :)
Sub Sample()
Dim DSOne() As String
Dim tmpAr As Variant
Dim wsCas As Worksheet: Set wsCas = ThisWorkbook.Sheets("Cases")
Dim wsMain As Worksheet: Set wsMain = ThisWorkbook.Sheets("Sheet1")
Dim lRow As Long, i As Long, j As Long
'~~> Check if user entered a color
If wsMain.Range("D3").Value = "" Then
MsgBox "Please enter a color first", vbCritical, "Missing Color"
Exit Sub
End If
'~~> Clear data for input in main sheet
wsMain.Range("F3:F" & wsMain.Rows.Count).ClearContents
'~~> Get last row of Sheet Cases
lRow = wsCas.Range("A" & wsCas.Rows.Count).End(xlUp).Row
With wsCas
'~~> Get count of cells which have that color
i = Application.WorksheetFunction.CountIf(.Columns(3), wsMain.Range("D3").Value)
'~~> Check if there is any color
If i > 0 Then
'~~> Define your array to hold those values
ReDim DSOne(1 To i, 1 To 4)
'~~> Store the Sheet Cases data in the array
tmpAr = .Range("A1:D" & lRow).Value
j = 1
'~~> Loop through the array to find the matches
For i = LBound(tmpAr) To UBound(tmpAr)
If tmpAr(i, 3) = wsMain.Range("D3").Value Then
DSOne(j, 1) = tmpAr(i, 1)
DSOne(j, 2) = tmpAr(i, 2)
DSOne(j, 3) = tmpAr(i, 3)
DSOne(j, 4) = tmpAr(i, 4)
j = j + 1
End If
Next i
'~~> write to the main sheet in 1 Go!
wsMain.Range("F3").Resize(UBound(DSOne), 4).Value = DSOne
End If
End With
End Sub
Screenshot:
Using the above approach now populate Dataset2 :)
Related
Hey i have a small problem that i can´t seam to solve... Im not the first to have this problem i found but none of the existing solutions worked on my code. so im stuck... The problem is that my code runs faster then what the functions can execute.
My code adds all worksheets that are of the same type together in a new sheet. And to indicate when how long every file is in the new sheet i want to change the interior of the last row to another color. My code can do that now but only in debug mode... and i don´t know how to "slow it down" so that i works whit my macro. Iv tried a delay function, DoEvent and adding a timer but none worked... Would really appreciate some tips on how to solve this or if there is a better way to do this. Thanks!
Sub MergeSheets()
Dim WorkSheetSource As Worksheet
Dim WorkSheetDestination As Worksheet
Dim RangeSource As Range
Dim RangeDestination As Range
Dim lngLastCol As Long
Dim lngSourceLastRow As Long
Dim lngDestinationLastRow As Long
Dim SheetName As String
Dim SkipSheets As String
'Set references up-front
Set WorkSheetDestination = ThisWorkbook.Worksheets("Import")
lngDestinationLastRow = LastOccupiedRowNum(WorkSheetDestination) '<~ defined below (and in Toolbelt)!
lngLastCol = LastOccupiedColNum(WorkSheetDestination) '<~ defined below (and in Toolbelt)!
'Set the initial destination range
Set RangeDestination = WorkSheetDestination.Cells(lngDestinationLastRow + 1, 1)
' (lngDestinationLastRow + 2) = what row to start adding on, 1 = start from column
' Skip this sheets ' the 2 makes a blank row between sheeeeets
SkipSheets = ("Import, Cover sheet, Control, Column description, Charts description")
'Loop through all sheets
For Each WorkSheetSource In ThisWorkbook.Worksheets ' Here i coud add a function where i can choose my Sheets?
DoEvents
'Make sure we skip the "Import" destination sheet!
If InStr(1, SkipSheets & ",", WorkSheetSource.Name & ",", vbTextCompare) = 0 Then
' Skip all Charts sheets
If InStr(WorkSheetSource.Name, "Status") Then
'Identify the last occupied row on this sheet
lngSourceLastRow = LastOccupiedRowNum(WorkSheetSource)
'Store the source data then copy it to the destination range
With WorkSheetSource
Set RangeSource = .Range(.Cells(3, 1), .Cells(lngSourceLastRow, lngLastCol)) ' 3 = what start row , 2 = how many columns
RangeSource.Copy Destination:=RangeDestination
End With
'Redefine the destination range now that new data has been added
LongDestinationLastRow = LastOccupiedRowNum(WorkSheetDestination)
Set RangeDestination = WorkSheetDestination.Cells(LongDestinationLastRow + 1, 1)
'LongDestinationLastRow.EntireRow.Interior.ColorIndex = 15
End If
' Find last row and give it colour
'Range("A" & Rows.Count).End(xlUp).Select
'ActiveCell.EntireRow.Interior.ColorIndex = 15
' don´t work... only in debugmode
End If
' **** Here the code works in debug mode but not in macro!*****
' Find last row and give it colour
Range("A" & Rows.Count).End(xlUp).Select
ActiveCell.EntireRow.Interior.ColorIndex = 15
'*************************************************************
Next WorkSheetSource
MsgBox "Done"
End Sub
I have two sheets "Data" - which has raw data and "Report" - as Report form .
Report sheet first 5 rows has info.
Data Sheet there 6 columns of Data available (SlNo Name Desig Place gender Category)
Report sheet has first 5 columns only (SlNo Name Desig Place gender)
Report sheet range C5 is dropdown box (List from Category column of Data sheet).
So based on this C5 value get details from Data sheet and paste in Report sheet.
I tried the following code but it pastes the whole row when I want to paste only Name,Desig,Place,gender details in offset and loop...
Sub ViewBtn()
Dim SCHL As String
Dim x As Long
x = 2
Do While Cells(x, 1) <> ""
Sheets("Report").Range(Cells(x, 1).Address, Cells(x, 5).Address).ClearContents
x = x + 1
Loop
Dim id As String
id = ActiveSheet.Range("C5").Value
x = 2
Sheets("Data").Select
Category = id
Do While Cells(x, 1) <> ""
If Cells(x, 4) = Category Then
Worksheets("Data").Rows(x).Copy
Worksheets("Report").Activate
erow = Sheets("Report").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Report").Rows(erow)
End If
Worksheets("Data").Activate
x = x + 1
Loop
Application.CutCopyMode = False
Worksheets("Report").Activate
End Sub
Here is some sample code to do what I think you are asking for. It is not necessarily the shortest or cleverest way to do it, but everything is done step by step so I hope it is clear enough to follow easily.
Option Explicit
Private Sub viewBtn_Click()
'// Set references to worksheets
Dim wsReport As Worksheet: Set wsReport = Sheets("Report")
Dim wsData As Worksheet: Set wsData = Sheets("Data")
'// Get the category to be reported
Dim sCategory As String
sCategory = wsReport.Range("C5")
'// Reference first line of the report, in row 8
Dim rFirstReportLine As Range
Set rFirstReportLine = wsReport.Range("A8:E8")
'// Reference the line of the report to be written
Dim rReportLine As Range
Set rReportLine = rFirstReportLine
'// Clear the old report area
Do While rReportLine.Cells(1, 1) <> ""
rReportLine.Clear
Set rReportLine = rReportLine.Offset(1, 0)
Loop
'// Reset to first line of the report
Set rReportLine = rFirstReportLine
'// Find the first cell, if any, that matches the category
Dim rMatch As Range
Set rMatch = wsData.Range("F:F").Find(sCategory, , , xlWhole)
'// Get reference to top data row of data sheet, just the cols to be copied
Dim rDataRow As Range: Set rDataRow = wsData.Range("A1:E1")
'// check for at least one match
If Not rMatch Is Nothing Then
'// Save the address of the first match for checking end of loop with FindNext
Dim sFirstMatchAddress As String: sFirstMatchAddress = rMatch.Address
Do
'// 1) .. copy data row to the report line
rDataRow.Offset(rMatch.Row - 1).Copy rReportLine
'// 2) .. move the report line down
Set rReportLine = rReportLine.Offset(1, 0)
'// 3) .. find the next match on category
Set rMatch = wsData.Range("F:F").FindNext(rMatch)
'// 4) .. exit when we have looped around
Loop Until rMatch.Address = sFirstMatchAddress
End If
'// Display the number of entries found at the end of the report
With rReportLine
Dim nEntryCount As Integer: nEntryCount = .Row - rFirstReportLine.Row
.Cells(1, 1) = nEntryCount & IIf(nEntryCount = 1, " Entry", " Entries")
.Font.Italic = True
.Font.Color = vbBlue
End With
'// Make sure the report sheet is displayed
wsReport.Activate
End Sub
With this data
Get this result
Just started a new job. I'm automating a month-end report and I'm new at VBA. Been googling most of my issues with success, but I've finally run into a wall. In essence I'm downloading some data from SAP and from there I need to build a report.
My question is: How to do a sumif function using loops in VBA?
Data pull:
Sheet1 contains a product code and purchase amounts (columns A & B) respectively. One product code can have several purchases (several rows with the same product code).
Steps so far:
I arranged the data sheet1 to be in ascending order.
Copied unique values for the product codes onto another sheet (sheet2). So Sheet2 has a list of all the products (in ascending order).
I want to get the sum of all purchases in sheet2 column B (per product code). I know how to do this using formulas, but I need to automate this as much as possible. (+ I'm genuinely interested in figuring this out)
This is what I did in VBA so far:
Sub Macro_test()
Dim tb As Worksheet
Dim tb2 As Worksheet
Dim x As Integer
Dim y As Integer
Dim lrow As Long
Set tb = Sheets("sheet1")
Set tb2 = Sheets("sheet2")
lrow = tb.Cells(Rows.Count, "A").End(xlUp).Row
For x = 2 To lrow
For y = 2 To lrow
If tb2.Cells(x, 1).Value = tb.Cells(y, 1).Value Then
tb2.Cells(x, 2).Value = tb.Cells(y, 2).Value
End If
Next y
Next x
End Sub
If i'm not mistaken, for each product_code in sheet2 col A, I'm looping through all the product codes in sheet1 and getting back the LAST value it finds, instead of the sum of all values... I understand why it doesn't work, I just don't know how to fix it.
Any help would be much appreciated. Thanks!
This statement overwrites the value of tb2.Cells(x, 2).Value at each iteration:
tb2.Cells(x, 2).Value = tb.Cells(y, 2).Value
Instead, I think you need to keep adding to it:
tb2.Cells(x, 2).Value = tb2.Cells(x, 2).Value + tb.Cells(y, 2).Value
But I don't like the looks of your double-loop which uses only one lrow variable to represent the "last row" on the two different worksheets, that could be causing some issues.
Or, in your loop do something like this which I think will avoid the duplicate sum. Still, assumes the second worksheet doesn't initially have any value in
' Base our lRow on Sheet2, we don't care how many rows in Sheet1.
lrow = tb2.Cells(tb2.Rows.Count, 1).End(xlUp).Row
Dim cl as Range
Set cl = tb.Cells(2,1) 'Our initial cell value / ID
For x = 2 to lRow '## Look the rows on Sheet 2
'## Check if the cell on Sheet1 == cell on Sheet2
While cl.Value = tb2.Cells(x,1).Value
'## Add cl.Value t- the tb2 cell:
tb2.Cells(x, 2).Value = tb2.Cells(x, 2).Value + cl.Offset(0,1).Value
Set cl = cl.Offset(1) '## Reassign to the next Row
Wend
Next
But it would be better to omit the double-loop and simply use VBA to do 1 of the following:
1. Insert The Formula:
(See Scott Holtzman's answer).
This approach is better for lots of reasons, not the least of which is that the WorksheetFunction is optimized already, so it should arguably perform better though on a small dataset the difference in runtime will be negligible. The other reason is that it's stupid to reinvent the wheel unless you have a very good justification for doing so, so in this case, why write your own version of code that accomplishes what the built-in SumIf already does and is specifically designed to do?
This approach is also ideal if the reference data may change, as the cell formulas will automatically recalculate based on the data in Sheet1.
2. Evaluate the formula & replace with values only:
If you prefer not to retain the formula, then a simple Value assignment can remove the formula but retain the results:
With .Range(.Range("B2"), .Range("A2").End(xlDown).Offset(, 1))
.FormulaR1C1 = "=SUMIF(Sheet1!C[-1]:C[-1],RC[-1],Sheet1!C:C)"
.Value = .Value 'This line gets rid of the formula but retains the values
End With
Use this approach if you will be removing Sheet1, as removing the referents will break the formula on Sheet2, or if you otherwise want the Sheet2 to be a "snapshot" instead of a dynamic summation.
If you really need this automated, take advantage of VBA to place the formula for you. It's very quick and easy using R1C1 notation.
Complete code (tested):
Dim tb As Worksheet
Dim tb2 As Worksheet
Set tb = Sheets("sheet1")
Set tb2 = Sheets("sheet2")
Dim lrow As Long
lrow = tb.Cells(tb.Rows.Count, 1).End(xlUp).Row
tb.Range("A2:A" & lrow).Copy tb2.Range("A2")
With tb2
.Range("A2").CurrentRegion.RemoveDuplicates 1
With .Range(.Range("B2"), .Range("A2").End(xlDown).Offset(, 1))
.FormulaR1C1 = "=SUMIF(Sheet1!C[-1]:C[-1],RC[-1],Sheet1!C:C)"
End With
End With
Note that with R1C1 notation the C and R are not referring to column or row letters . Rather they are the column and row offsets from the place where the formula is stored on the specific worksheet. In this case Sheet!C[-1] refers to the entire A column of sheet one, since the formula is entered into column B of sheet 2.
I wrote a neat little algorithm (if you can call it that) that does what you want them spits out grouped by totals into another sheet. Basically it loops through the first section to get unique names/labels and stores them into an array. Then it iterates through that array and adds up values if the current iteration matches what the current iteration of the nested loop position.
Private Sub that()
Dim this As Variant
Dim that(9, 1) As String
Dim rowC As Long
Dim colC As Long
this = ThisWorkbook.Sheets("Sheet4").UsedRange
rowC = ThisWorkbook.Sheets("Sheet4").UsedRange.Rows.Count
colC = ThisWorkbook.Sheets("Sheet4").UsedRange.Columns.Count
Dim thisname As String
Dim i As Long
Dim y As Long
Dim x As Long
For i = LBound(this, 1) To UBound(this, 1)
thisname = this(i, 1)
For x = LBound(that, 1) To UBound(that, 1)
If thisname = that(x, 0) Then
Exit For
ElseIf thisname <> that(x, 0) And that(x, 0) = vbNullString Then
that(x, 0) = thisname
Exit For
End If
Next x
Next i
For i = LBound(that, 1) To UBound(that, 1)
thisname = that(i, 0)
For j = LBound(this, 1) To UBound(this, 1)
If this(j, 1) = thisname Then
thisvalue = thisvalue + this(j, 2)
End If
Next j
that(i, 1) = thisvalue
thisvalue = 0
Next i
ThisWorkbook.Sheets("sheet5").Range(ThisWorkbook.Sheets("Sheet5").Cells(1, 1), ThisWorkbook.Sheets("Sheet5").Cells(rowC, colC)).Value2 = that
End Sub
Yay arrays
I am creating a macro to help organize a data dump (sheet 1) into an invoice (sheet 2). I have coded most of the macro, but am stuck on the following.
I want the macro to read column Y on sheet 1, which is a variable range (can be 2 rows to 50) and check if it says "CB". If this is true, then E11 on sheet 2 is Yes, otherwise No, and so on until it reaches the end of column Y on sheet 1.
I have the following:
Sheets("Data_Dump").Select
intCounter = 1
While Range("Y" & (intCounter + 1)) <> ""
intCounter = intCounter + 1
Wend
intCardSize = intCounter
MsgBox (intCardSize)
Sheets("Data_Dump").Select
If Range("Y" & intCardSize) = "CB" Then
Sheets("Reconciliation").Select
Range("E11:E" & intCardSize).Select
Range("E11") = "Yes"
End If
The while range seems to work and it displays the number of cells with text in column Y, but I can't seem to wrap my head around how to get it to move from Y1 to Y2 and so on and then paste the response into E11 then E12 and so on.
The problem that you are having is that your code doesn't loop to try to compare. The While loop that you have only looks to see if there is something in the next cell. In fact, it actually skips the first row, but maybe that was intentional.
Dim dataSheet As WorkSheet
Dim recSheet As Worksheet
Dim lngCounter As Long 'Use long because an integer may not be big enough for large dataset.
Dim intCardSize As Long
Set dataSheet = ThisWorkbook.Sheets("Data_Dump")
Set recSheet = ThisWorkbook.Sheets("Reconciliation")
'You want to set the sheets to a variable instead of referring to the whole path each time
'Also, Note the usage of "ThisWorkbook" which guarantees the worksheet
'is coming from the one with code in it.
lngCounter = 2 'If you want to start looking at row 2, start at row 2 with
'the variable instead of starting the variable and checking var+1
While dataSheet.Range("Y" & (lngCounter)) <> ""
'While there is a value in the column
'intCardSize = intCounter 'Not sure what this is supposed to do
'MsgBox (intCardSize) 'This looks like debugging. Commenting out.
If dataSheet.Range("Y" & lngCounter) = "CB" Then
'Check each row as you go through the loop.
'Sheets("Reconciliation").Select
'Avoid selecting sheet/range. Unneccessary work for computer.
recSheet.Range("E" & (9 + lngCounter)) = "Yes"
'Set reconciliation sheet value to "Yes" if data sheet has "CB"
'The reconciliation sheet starts on row 11, whereas the datasheet
'starts at row 2 ,a difference of 9
Else
recSheet.Range("E" & (9 + lngCounter)) = "No"
'Otherwise set to no.
End If
lngCounter = lngCounter + 1
Wend
intCardSize = lngCounter - 1 'It's been increased to one past the last item.
MsgBox intCardSize 'Display the last row checked.
I hope I understood your code goal as follows
With Sheets("Data_Dump")
With Sheets("Reconciliation").Range("E11").Resize(.Cells(.Rows.Count,1).Row)
.Formula="=IF('Data_Dump'!Y1="CB", "Yes","")"
.Value= .Value
End With
End With
I need a little bit help with a macro of Excel.
I need to create a macro that automatically find users and copy the values that i have in an other Sheet:
I have one sheet with values that contains the Users and their Kills and Deaths, I create 3 sheets more (3 different groups of users), and I need that the macro copy values automatically finding the users and copying values.
Images to describe it better:
----(Copy this values on)----->
You don't need a macro for this, using the worksheetfunction VLOOKUP is sufficient.
As an example, if you have your headers in row 1 and users in column A, what you'd put into cell B2 (the number of kills for the first user) would be =VLOOKUP($A2;Values!$A$2:$C$9;2;FALSE) and C2 would be =VLOOKUP($A2;Values!$A$2:$C$9;3;FALSE).
The arguments for the function (which you can also find in the linked document) is:
First, the value you're looking for, in your case whatever is in A2
Next the array of values which you want to return a result from - vlookup will only look through the first column, but since you want to return results from the other columns we include columns A:C in the formula.
What column in the range you search to return the result from for kills it is column 2, for deaths column 3.
Finally whether you want to have an exact match (false) or if an approximate one is ok (true).
If I understand what you're after, you should be able to do this with VLOOKUPs
(No VBA necessary)
The following source code solve your problem.
Option Explicit
Dim MyResultWorkbook As Workbook
Dim ValuesWorksheet As Worksheet
Dim SniperWorksheet As Worksheet
Dim ARsWorksheet As Worksheet
Sub CopyResult()
Set MyResultWorkbook = ActiveWorkbook
Set ValuesWorksheet = MyResultWorkbook.Sheets("Values")
Set SniperWorksheet = MyResultWorkbook.Sheets("Sniper")
Set ARsWorksheet = MyResultWorkbook.Sheets("Ars")
Dim SniperLastRow As Long
Dim ARLastRow As Long
Dim RowPointer As Long
Dim ValuePointer As Long
ValuePointer = 2
'Update the Sniper worksheets
SniperLastRow = SniperWorksheet.Cells(SniperWorksheet.Rows.Count, "A").End(xlUp).Row
For RowPointer = 2 To SniperLastRow
Do While (SniperWorksheet.Range("A" & RowPointer).Value <> ValuesWorksheet.Range("A" & ValuePointer).Value)
ValuePointer = ValuePointer + 1
Loop
SniperWorksheet.Range("A" & RowPointer).Offset(0, 1).Value = ValuesWorksheet.Range("A" & ValuePointer).Offset(0, 1).Value 'copy kill
SniperWorksheet.Range("A" & RowPointer).Offset(0, 2).Value = ValuesWorksheet.Range("A" & ValuePointer).Offset(0, 2).Value 'copy death
ValuePointer = 2
Next
'Update the Ars worksheets
ARLastRow = ARsWorksheet.Cells(ARsWorksheet.Rows.Count, "A").End(xlUp).Row
For RowPointer = 2 To ARLastRow
Do While (ARsWorksheet.Range("A" & RowPointer).Value <> ValuesWorksheet.Range("A" & ValuePointer).Value)
ValuePointer = ValuePointer + 1
Loop
ARsWorksheet.Range("A" & RowPointer).Offset(0, 1).Value = ValuesWorksheet.Range("A" & ValuePointer).Offset(0, 1).Value 'copy kill
ARsWorksheet.Range("A" & RowPointer).Offset(0, 2).Value = ValuesWorksheet.Range("A" & ValuePointer).Offset(0, 2).Value 'copy death
ValuePointer = 2
Next
End Sub