I'm a VBA noob with a massive table of analysis results where each row is containing results from a different date. I'm looking for values in certain columns, and they are some times empty. When they are, I'm not interested in them. The values I want are supposed to be copied to a new sheet to be collected in a smaller table.
I have written a script where I loop through the rows in the masterTable, and I am able to identify the rows with the values I'm interested in. However, I am not able to copy the value from the different cells in the identified row to a new sheet.
I've tried using Union to make a range inlcuding the columns that are relevant for copying.
Dim searchCells As Range
Dim masterTable As Range
Set searchCells = Union(Columns("R"), Columns("S"), Columns("T"), Columns("X"), Columns("Z"), Columns("AF"), Columns("AQ"), Columns("AT"), Columns("AY"), Columns("AV"), Columns("BB"), Columns("BD"), Columns("BG"))
Set masterTable = Worksheets("Sheet0").Range("A3:BG2022")
a = 1
For i = 1 To masterTable.Rows.Count
If Application.WorksheetFunction.CountA(searchCells(i).Value) <> 0 Then ' look for values among the relevant columns in row(i).
Debug.Print "Found data at "; i
Worksheets("Sheet0").searchCells.Rows(i).Copy ' copy data from searchCells
Worksheets("Results").Range("C1").Offset(a, 0).paste ' paste data to destination
a = a + 1 ' increment destination row offset
End If
Next
My idea of the searchCells are not working, as I "find data" in all rows, and I'm not able to run the .Copy and the .Paste methods. All help is appreaciated!
EDIT: upon compilation VBA throws the following error on the copy-line:
Run-time error '438':
Object doesn't support this property or method
To copy the relevant rows (for those columns only) where there is data in at least one cell, you could use:
Dim searchCells As Range
Dim masterTable As Range
Dim rRow As Range
Set searchCells = Range("R:T,X:X,Z:Z,AF:Af,AQ:Aq,AT:AT,AV:AV,AY:AY,BB:BB,BD:BD,BG:BG")
Set masterTable = Worksheets("Sheet0").Range("A3:BG2022")
a = 1
For i = 1 To masterTable.Rows.Count
Set rRow = Intersect(searchCells, searchCells.Cells(i, 1).EntireRow)
If Application.WorksheetFunction.CountA(rRow) <> 0 Then ' look for values among the relevant columns in row(i).
Debug.Print "Found data at "; i
rRow.Copy Worksheets("Results").Range("C1").offset(a, 0) ' paste data to destination
a = a + 1 ' increment destination row offset
End If
Next
Related
Effectively what I am trying to accomplish is to filter a database (all in Sheet 1) by names, which are given in column A, and then perform various data analysis on the now filtered visible data, and then copy that data to a new sheet in a given cell.
For example, filter the data in Sheet 1 by the name 'Smith' in column A and then let's say sum all of the visible data in column B and print that to cell C3 on Sheet 2. The more advanced data analysis I am sure I can tackle on my own, just want to get rolling here and I am definitely new to VBA macro coding. I have created all of these databases using Python.
The last piece of this, would be being able to loop through all of the filter criteria in column A (which I will not know before-hand and may be anywhere from 10-20 names.
Here is the code I am working with (there are likely some syntax errors in here as well):
Option Explicit
Sub Data()
Dim playername As String
Dim team As String
Dim numFilters As Integer
Dim hits As Integer
Dim src As Worksheet
Dim tgt As Worksheet
Dim filterRange As Range
Dim copyRange As Range
Dim lastRow As Long
Dim i As Integer
team = ThisWorkbook.Sheets(1).Name
numFilters = ActiveSheet.AutoFilter.Filters.Count ' I want this to capture the num of filter criteria for column A
For i = 1 To numFilters
playername = Sheets(team).Filter(i) ' This would be the filter criteria for the given iteration
ActiveSheet.Range("$A$1:$AN$5000").AutoFilter field:=1, Criteria1:=playername
' Create new sheet with name of person
Sheets.Add After:=ActiveSheet
ActiveSheet.Select
ActiveSheet.Name = playername
Set tgt = ThisWorkbook.Sheets(i + 1)
' Perform data analysis (e.g. sum column B of filtered data)
src.AutoFilterMode = False
' Find the last row with data in column A
lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
' The range that we are auto-filtering (all columns)
Set filterRange = src.Range("A1:AN" & lastRow)
' Set the range to start in row 2 to prevent copying the header
Set copyRange = src.Range("B2:B" & lastRow)
' Copy the sum of column B to our target cell on the sheet corresponding to this iteration
Application.WorksheetFunction.Sum(copyRange.SpecialCells(xlCellTypeVisible)).Copy tgt.Range("A1")
Next i
End Sub
This is currently failing on the Application.WorksheetFunction.Sum line with the error 'Invalid qualifier'. Thanks for any help and please let me know if something needs clarified.
Sheet 1 holds a full list of the current state of work orders
Sheet 2 holds recent changes to those work orders and any new work orders
Both sheets have the same format with data in columns A to L.
I need to use Sheet 2 to update the full list held in Sheet 1. Work orders have a unique identifier which is held in column A of each sheet.
In general terms:
Process each row of Sheet 2.
If a matching work order already exists in Sheet 1, update it.
If no matching work order exists in Sheet 1, add it as a new row in Sheet 1.
In column A is the work order number.
There may be better ways to do this, and as #Jeeped said, this has probably been asked before (though I couldn't find it). Hopefully the following is what you need. I've included lots of comments to help you understand the code and modify it should you need to.
Sub ProcessDelta()
'Define the worksheets
Dim shtDelta As Worksheet
Dim shtMaster As Worksheet
Set shtDelta = Worksheets("Sheet2")
Set shtMaster = Worksheets("Sheet1")
Dim intDeltaStartRow As Integer
'I assume there is a header row in the Delta sheet, if not, set this to 1
intDeltaStartRow = 2
Dim intMaxEverWorkOrders As Integer
'One of several ways to find the first blank row in the Master
'sheet is to start somewhere beyond the data and move up
'we use this later
intMaxEverWorkOrders = 1000000
Dim cellDeltaWorkOrder As Range
'Work order from Delta to be processed
Set cellDeltaWorkOrder = shtDelta.Cells(intDeltaStartRow, 1)
'For the destination to which we copy
Dim cellMasterWorkOrder As Range
Dim boolNewWorkOrder As Boolean
'Default to assume it's not a new workorder
boolNewWorkOrder = False
'We'll work from top to bottom in the Delta sheet. When the cell is blank we've finished
While cellDeltaWorkOrder.Value <> ""
'We're going to search for the "current" workorder from the Delta in the Master.
'If it's not there, we'll get an error. So we use "On Error" to handle it
On Error GoTo ErrorStep
'If there is no error, after the following line cellMasterWorkOrder will be the cell containing the matching workorder
Set cellMasterWorkOrder = shtMaster.Cells(WorksheetFunction.Match(cellDeltaWorkOrder.Value, shtMaster.Cells(1, 1).EntireColumn, 0), 1) '
'Reset error handling so any other errors are reported normally
On Error GoTo 0
'Check whether there was an error, if there was this was a new Workorder and needs to go at the end, so set the target cell accordingly
If boolNewWorkOrder = True Then
Set cellMasterWorkOrder = shtMaster.Cells(intMaxEverWorkOrders, 1).End(xlUp).Offset(1, 0)
boolNewWorkOrder = False 'reset this so we can check again for the next row to be processed
End If
'Output Row into Master
cellMasterWorkOrder.EntireRow.Value = cellDeltaWorkOrder.EntireRow.Value
'Move to next row in the Delta
Set cellDeltaWorkOrder = cellDeltaWorkOrder.Offset(1, 0)
Wend
'We don't want to run the error step at this point so ..
Exit Sub
ErrorStep:
'It wasn't found, which throws an error, and so it needs added as a new row.
boolNewWorkOrder = True
Resume Next
End Sub
I have 2 different files which have different headers, for example:
OldfileHeaders | NewFileheaders
ID | Test ID
Date | New date
and so on. I am trying to compare the data in both sheets and see if they match. The rows of data may be in different order and the headers may also be in different order.
So what I am trying to do is:
1) define which headers match which headers between the 2 files
2) find the ID from the oldfile and see if it is in the new file, if it is then see if the data under each header matches. If it doesn't then export that row of data to a new sheet add a column and label it "Missing".
The Code So far:
Set testIdData = testIdData.Resize(testIdData.CurrentRegion.Rows.Count)
Do Until sourceId.Value = ""
datacopy = False
' Look for ID in test data
Set cellFound = testIdData.Find(What:=sourceId.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If cellFound Is Nothing Then
' This entry not found, so copy to output
datacopy = True
outputRange.Resize(ColumnSize:=NUMCOLUMNS).Interior.Color = vbRed
Else
' This assumes that columns are in same order
For columnNum = 2 To NUM_COLUMNS_DATA
' No need to test the ID column
If sourceId.Cells(ColumnIndex:=columnNum).Value <> cellFound.Cells(ColumnIndex:=columnNum).Value Then
outputRange.Cells(ColumnIndex:=columnNum).Interior.Color = vbYellow
datacopy = True
End If
Next columnNum
End If
If datacopy Then
sourceId.Resize(ColumnSize:=NUMCOLUMNS).Copy
outputRange.PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
Set outputRange = outputRange.Offset(RowOffset:=1)
difference = difference + 1
End If
Set sourceId = sourceId.Offset(RowOffset:=1)
Loop
This code works depending on me formatting the sheets in the correct order and changing the header names.
I need help in defining which field names match which field names within the 2 sheets, and then searching the new sheet for each ID and seeing if the data in the corresponding cells match. If the ID is not in the sheet then output that row too a different sheet. If the id is present and there are differences in the cells then out put these to the shame sheet. I want to produce a tally of differences in each column.
Matching up data between data sets requires that you give the program some help. In this case, the help needed is which columns are related to each other. You have identified a small table of how headers are related. With this, you can do the various translations from data source 1 to data source 2. It requires heavy usage of Application.Match and Application.VLookup.
I will provide a base example which does the core of what you are trying to do. It is much easier to see it all on one sheet which is what I have done.
Picture of data shows three tables: rng_headers, rng_source, and rng_dest. One is the lookup for the headers, the second is the "source" data, and the third is the data source to compare against which I will call destination = "dest".
Code include steps to: iterate through all the IDs in the source data, check if they exist in the dest data, and, if so, check all the individual values for equality. This code checks the headers on every step (which is slow) but allows for the data to be out of order.
Sub ConfirmHeadersAndMatch()
Dim rng_headers As Range
Set rng_headers = Range("B3").CurrentRegion
Dim rng_dest As Range
Set rng_dest = Range("I2").CurrentRegion
Dim rng_source As Range
Set rng_source = Range("E2").CurrentRegion
Dim rng_id As Range 'first column, below header row
For Each rng_id In Intersect(rng_source.Columns(1).Offset(1), rng_source)
Dim str_header As Variant
str_header = Application.VLookup( _
Intersect(rng_id.EntireColumn, rng_source.Rows(1)), _
rng_headers, 2, False)
'get col number
Dim int_col_id As Integer
int_col_id = Application.Match(str_header, rng_dest.Rows(1), 0)
'find ID in the new column
Dim int_row_id As Variant
int_row_id = Application.Match(rng_id, rng_dest.Columns(int_col_id), 0)
If IsError(int_row_id) Then
'ID missing... do something
rng_id.Interior.Color = 255
Else
Dim rng_check As Range 'all values, same row
For Each rng_check In Intersect(rng_source, rng_id.EntireRow)
'get col number
str_header = Application.VLookup( _
Intersect(rng_check.EntireColumn, rng_source.Rows(1)), _
rng_headers, 2, False)
int_col_id = Application.Match(str_header, rng_dest.Rows(1), 0)
'check value
If rng_check.Value <> rng_dest.Cells(int_row_id, int_col_id).Value Then
'values did not match... do something
rng_dest.Cells(int_row_id, int_col_id).Interior.Color = 255
End If
Next rng_check
End If
Next
End Sub
Notes on the code
Ranges are built on CurrentRegion which picks out the blocks of data. You can swap these out for different ranges on different sheets.
Column header translation is done with Application.VLookup to check the source header and return the destination header. This String is then found in the destination header row using Application.Match. You could abstract this code into a Function to avoid repeating it twice.
Once the column is found, the ID is searched for in the destination table using Application.Match. This will return an error if the ID is not found.
If the ID is found, it then checks all of the other values in the same row, comparing them against the correct columns in the destination table. Non-matching results are colored red.
If all of the columns do not have pairs, you can add additional checks on the VLookup or the column Match to check this.
The vast majority of this code just handles getting to the correct spots in the data using Intersect, Rows, and Columns.
Results show some red values for the ID not found and the values that don't match.
I have an Excel spreadsheet with a few hundred files. Within each file is several images. I need each image to have a new row inserted under the "parent" file row. I have code that will insert the correct number of rows, but it won't go to the next cell and none of the offset's I change are fixing it.
Sub CB3262014()
Dim i As Integer, n As Integer, m As Long, currentCell As Range
Set currentCell = ActiveCell
Do While Not IsEmpty(currentCell)
n = currentCell.Value
m = currentCell.Row
If n > 0 Then
Rows(m + 1 & ":" & m + n).Insert
Set currentCell = currentCell.Offset(n + 1, 0)
Else
Set currentCell = currentCell.Offset(1, 0)
End If
Loop
End Sub
I'm also struggling with how to get it to jump down/skip two rows each time. The way my data set is set up, there's two rows - then the row with the parent file and the reference number for how many additional rows to add.
Here's a sample from the spreadsheet and how I would like it to be. I will fill in file names, I just put them there so it's easier to see what's happening.
Current Spreadsheet [1]: http://i.stack.imgur.com/zRdXE.png
Goal Spreadsheet [2]: http://i.stack.imgur.com/6evMO.png
By inspection of the attached images, it seems the loop is looping down rows with blanks in. The loop therefore stops immediately on encountering the first blank due to:
Do While Not IsEmpty(currentCell)
So, replace that with Do Until currentCell is Range("C100000").End(xlUp) and the loop should continue as expected. A minor performance improvement would be to cache that cell to save evaluating it each loop such as:
Dim lastCell As Range
Set lastCell = Range("C100000").End(xlUp)
Do Until currentCell is lastCell
...etc
Loop
So, I've explored a few answered VBA Questions, but I'm still stuck. I have three sheets "By_Oppt_ID", "Top_Bottom" and "Non_Top_Bottom". The first two have a large amount of columns each with a unique name. Now there are some columns in By_Oppt_ID that aren't in "Top_Bottom". So I want to compare each column name in By_Oppt_ID to every column name in "Top_Bottom", and if the column name isn't found, copy that column name and all the rows beneath it, to a third worksheet "Non_Top_Bottom".
So Here's what I have:
Sub Copy_Rows_If()
Dim Range_1 As Worksheet, Range_2 As Worksheet
Dim c As Range
Set Range_1 = Workbooks("Complete_Last_Six_Months_Q_Results.xlsx").Sheets("Top_Bottom")
Set Range_2 = Workbooks("Complete_Last_Six_Months_Q_Results.xlsx").Sheets("By_Oppt_ID")
Application.ScreenUpdating = False ' Stays on the same screen even if referencing different worksheets
For Each c In Range_2.Range("A2:LX2")
' Checks for values not in Range_1
If Application.WorksheetFunction.CountIf(Range_1.Range("A1:CR1"), c.Value) = 0 Then
' If not, copies rows to new worksheet
' LR = .Cells(Row.Count, c).End(xUp).Row
c = ActiveCell
Sheets("By_Oppt_ID").Range("Activecell", "ActiveCell.End(xlDown)").Copy Destination:=Workbooks("Complete_Last_Six_Months_Q_Results.xlsx").Sheets("Non_Top_Bottom").Range("A1:A6745")
Set rgPaste = rgPaste.Offset(0, 1) 'Moves to the next col, but starts at the same row position
End If
Next c
End Sub
I've compiled this many ways and keep getting a series of errors: Subscript Out of Range/ Method "Global_Range" Failure. What am I doing wrong?
If you are going to have this code within the same workbook every time, try using
ThisWorkbook.Sheets("Top_Bottom")
instead of
Workbooks("Complete_Last_Six_Months_Q_Results.xlsx").Sheets("Top_Bottom")
replicate that through your code and see if that fixes the problem.
What do you mean by c = Activecell? Do you mean to say c.activate?
You might then also want to change the next line to
Sheets("By_Oppt_ID").Range(Activecell, ActiveCell.End(xlDown)).Copy Workbooks("Complete_Last_Six_Months_Q_Results.xlsx").Sheets("Non_Top_Bottom").Range("A1")