I have a task to complete where I want to create a table using values from one sheet based on condition using VBA and ActiveX Button.
This are table entries from which I need to pick values based on condition Cell(J, 62).values = "Not Compliant" or "Partially Compliant".
To understand it better, where ever in column J the value is "Not Compliant or Partially Compliant" for rows I want certain details to be included in a new sheet as dynamic entries. Below is the format of the new table that I would like to create. I have mentioned the column names that I want in the new table.
Column C | Serial No. (Values based number of entries) | Column L | Column M
The number of values may depend on the number of Not Compliant and Partially compliant numbers.
Can anyone help me getting a code for this. I am unable to write a logic for this condition.
Assuming you have 2 Sheets in your Workbook where the first sheet is your Table and the second sheet is the destination for the items where the data is not compliant:
Option Explicit
Sub RunComplianceCheck()
Dim c As Range 'Each cell that the loop will look at to determine Compliance Status
Dim rng As Range 'The range of all the entries in the table
Dim totNC 'The total Non or Partially Compliance entries on the second tab
Sheet2.Activate
Sheet2.Range(Cells(2, 1), Cells(2, 1).SpecialCells(xlLastCell)).ClearContents 'Clear all previous data
Sheet1.Activate
With Sheet1
Set rng = .Range(Cells(2, 10), _
Cells(Application.WorksheetFunction.CountA(.Range("J:J")), 10)) 'Set the range of all the entries in the table
End With
For Each c In rng 'Loop through each entry
If c.Value = "Not Compliant" Or c.Value = "Partially Compliant" Then 'If Not Compliant or Partially Complaint execute the below
With Sheet2
totNC = Application.WorksheetFunction.CountA(.Range("A:A")) + 1 'Get the first empty row on the second Sheet of Non or Partially Compliant data
.Cells(totNC, 1).Value = c.Offset(0, -7).Value 'Get data in column C
.Cells(totNC, 2).Value = c.Offset(0, -9).Value 'Get data in column A
.Cells(totNC, 3).Value = c.Offset(0, 2).Value 'Get data in column L
.Cells(totNC, 4).Value = c.Offset(0, 3).Value 'Get data in column M
End With
End If
Next c 'Next cell
Sheet2.Activate
End Sub
This sub will loop through each row of your data set and find the entries marked Non-Compliant or Partially Compliant, then will grab the Question(s), Serial No., Finding / Gap Description, and Finding Rating data for each one (as requested) and place them in the second sheet.
Related
I have a project that I am working on where multiple conditions are checked across all rows and many columns. The issue is that columns are added/removed from the sheet, and, at present, that results in all of my cell(row,column) references being off + outputting incorrect information. I'm wondering if there's a way to make my column references more robust so that they automatically find the correct headers and use them when checking? Would a solution to this problem be able to account for multiple columns containing the exact same header text?
Basically:
No blank columns
Column headers have repeats (e.g., Column 1 header: "Financials"; Column 15 header: "Financials")
Columns are shifting right and left based on adding/removing columns from sheet
Please find a short sample of my current code below with notes:
Dim i As Integer
Dim lastRow As Long
Dim lastCol As Long
lastRow = Range("A1").End(xlDown).Row
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
For i = 2 To lastRow
Select Case Cells(i, 14).Value
Case Is = "Yes"
Select Case True
Case Cells(i, 63).Value = 6 And _
(IsEmpty(Cells(i, 77)) Or IsEmpty(Cells(i, 93)) Or IsEmpty(Cells(i, 109)) Or _
IsEmpty(Cells(i, 125)) Or IsEmpty(Cells(i, 141)) Or IsEmpty(Cells(i, 157)))
Cells(i, 174).Value = "True" '^THESE CELL VALUES ALL HAVE THE SAME COLUMN HEADER TITLE
If the table is consistent - starting at A1 and occupying a contiguous block - then Range("A1").CurrentRegion will reference the table.
You can then use .CreateNames to name the columns (that is, using Named Ranges) according to their headings.
Dim rngTable As Range
Dim rng As Range
Set rngTable = Range("A1").CurrentRegion
rngTable.CreateNames True, False, False, False
' that is, based on the first row headings
Range("Salary").Select 'prove it works
'if necessary, iterate the cells of the column,
For Each rng In Range("Salary")
rng.Value = rng.Value + 10
Next 'rng
If a column heading is duplicated ("Financial"), though, then you'll be asked to confirm and the second occurrence will overrule the first. (Or you could say "No" and the first occurrence will be named.) In which case, it is preferable that you first correct these duplicate headings.
Correcting the duplicate headings is not necessarily straight forward, but something that you should resolve anyway. If it is a specific word "Financials" (or words) that could be duplicated then this makes the task easier. You could count how many occurrences there are, and correct the second, etc., to "Financials2".
One easy way to to assign a Name to the column. Say column N has the header "Payments". First assign the Name "Payments" to that column:
Then in VBA we can code like:
Sub dural()
Dim rng As Range, colly As Long
Set rng = Range("Payments")
colly = rng.Column
For i = 2 To 100
If Cells(i, colly) = "whatever" Then
MsgBox "Help"
End If
Next i
End Sub
The code will continue to work even if you add/remove columns beforre column N.
I have done my best to read every thread imaginable to rewrite my overall code to get this to work.
Situation: I have data in sheet2 (Scores) and data in sheet3 (Comments). In each sheet, column A has a ticket number. The Scores sheet includes every possible ticket number; the Comments sheets only includes a subset of that total (approx 50%). The Scores sheet includes 4 populated columns while the Comments sheet has 2. I need the lookup to match the common existing rows (ticket numbers), and then take the value in Comments column B (2) and paste it in Column E (5) of sheet1, which is the CSAT Summary sheet, and has the contents of Col A-D from the Scores sheet.
Below is the current code. If I remove the VLookup and just put a variable (such as "A"), it does paste A in the correct column, albeit on every single line...
scores.UsedRange.Columns.Copy
csatSum.Range("A1").Insert
csatSum.Activate
Set rng = csatSum.Range("A2:A" & lastRow)
rngLastRow = Comments.Range("B2:B" & lastRow)
For i = 2 To lastRow
On Error Resume Next
csatSum.Cells(i, 5) = WorksheetFunction.VLookup(rng, Comments.Range(rngLastRow), 2, False)
On Error GoTo 0
Next i
Not sure what I am missing. Obviously it is something in the VLookup itself. But I am at a loss.
I think it should be:
scores.UsedRange.Columns.Copy
csatSum.Range("A1").Insert
'csatSum.Activate
'Set rng = csatSum.Range("A2:A" & lastRow)
Set rngLastRow = Comments.Range("A2:B" & lastRow)
For i = 2 To lastRow
On Error Resume Next
csatSum.Cells(i, 5) = WorksheetFunction.VLookup(csatSum.Cells(i, 1), rngLastRow, 2, False)
On Error GoTo 0
Next i
I have a table (Table 1) with a whole bunch of well data (versions, MD, HD, etc.) and I want to create another table (Table 2) that will only show the data for the well I am interested in.
I have it set up where you select the well using a drop down list. Then I want Table 2 to be populated with four values for each of the iterations that show up in Table 1....
I tried using vlookup but was having issues when a well had multiple versions. And I also tried using an advanced filter.
Screenshot of the spreadsheet
Let's solve this using a helper column. First, assume column A will be used to the left of your table, to show the row number which each one of these is found in.
A5 would have the following formula:
=MATCH($C$1,K:K,0)
This shows us the row number that Well1 is first matched at. Then A6 and copied down would have the formula:
=A5+MATCH(B6,OFFSET(K1,A5,0,COUNT(M:M),1),0)
This uses OFFSET to create a new range, starting at the cell immediately below the previous match for Well1, and then uses MATCH to find what row that occurs.
So now, column A will always show the row number to pull data from. The rest is simply using the INDEX function to pull from your desired columns. For example, the data in column C pulls the iteration from column L, and can be pulled through formula like so, in cell C5 and copied to the right / down:
=INDEX(L:L,$A5)
If your data is appropriately normalized, you might be better off with a Pivot Table. This would give you the option of filtering by Well ID.
To use a Advanced filter you will need to create a worksheet event. Place this in the code for the sheet on which you want the data.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A2")) Is Nothing Then
Dim dataRng As Range
Dim critRng As Range
Dim CpyToRng As Range
Dim cpytoarr() As Variant
With Worksheets("Sheet1")
Set dataRng = .Range(.Cells(1, 1), .Cells(1, 1).End(xlDown).End(xlToRight))
End With
With Me
.Range("CC1") = .Cells(1, 1).Value
.Range("CC2") = "'=" & .Cells(2, 1).Value
Set critRng = .Range("CC1:CC2")
Set CpyToRng = .Range(.Cells(6, 1), .Cells(6, 1).End(xlToRight))
End With
Debug.Print dataRng.Address
Debug.Print critRng.Address
Debug.Print CpyToRng.Address
dataRng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=critRng, CopyToRange:=CpyToRng, _
Unique:=False
critRng.ClearContents
End If
End Sub
How this works. This assumes the data is on Sheet1 and starts in "A1" with no blanks in column A or the last row:
On Sheet2 set it up like this:
It is important that the header rows on sheet2 are name identical to the headers on sheet1.
Now every time that the value changes in A2 on sheet 2, your drop down, the requisite data will appear below row 6.
I have a list of query words that I am submitting to a database (Column A) to generate a list of coded matches (Columns F-H). Column F is the original search word (so there is an exact match somewhere in Column A), Column G contains the match, and Column H contains the code for the match. What I need to do is take the query word in Column F and find its partner in Column A. Then I need to take the corresponding match and its code and paste it next to the original search term in Column A (in Columns B&C).
My problem here is getting the information pasted in the correct cell since the copy to and paste from locations change every time -- The list of coded matches in Columns F-H does NOT contain all of the terms in Column A.
I've been searching the internet and I can't seem to figure out what exactly I need to change to allow the paste function to work.
I have attached an image of a simplified version of my spreadsheet and a annotated version of the code I have been working with.
Sub FindMatch()
LastRow = Cells(Rows.Count, 6).End(xlUp).Row
For i = 1 To LastRow
FindMe = Cells(i, 6).Value
Set FoundinList = Cells.Find(What:=FindMe, After:=ActiveCell, LookAt:=xlWhole)
If Not FoundinList Is Nothing Then
FoundinList.Select
ActiveCell.Offset(0, 1).Select
'At this point the cell I want the information pasted into is selected. Yay!
'Example: I am trying to find "abnormal digits" (F1) in Column A and paste
'G1:H1 into the appropriate cells in Columns B & C (In this case B15:C15)
'At this point in the code my cursor is on cell B15 - which is where I need it.
Range(Cells(i, 7), Cells(i, 8)).Copy
'This selects the appropriate range (G1:H1 in my example).
ActiveCell.Paste
'This is the problem string. I've tried naming the "ActiveCell" before initiating the copy
'string (ActiveCell.Name = "PasteHere") and then pasting into the named cell
'(Cells("PasteHere").Paste), but that gives me an invalid procedure call or argument on:
'Cells("PasteHere").Paste I've also tried pasting into a range:Range(Cells(PasteHere, 2)
', Cells(PasteHere, 3)).Paste -AND- using the formula that is created when you a record a
'macro (Application.CutCopyMode = False) but both of those give me an application
'/object-defined error.
End If
Next i
End sub
Thank you so much in advance for reading this post and helping me out.
My Spreadsheet
End Product
This vba uses the worksheet function vlookup.
Sub ahhn()
Dim ws As Worksheet
Dim cel As Range
Set ws = ActiveSheet
With ws
For Each cel In .Range(.Range("A1"), .Range("A1").End(xlDown))
cel.Offset(0, 1) = WorksheetFunction.IfError(Application.VLookup(cel, .Range("F:H"), 2, 0), "")
cel.Offset(0, 2) = WorksheetFunction.IfError(Application.VLookup(cel, .Range("F:H"), 3, 0), "")
Next
End With
End Sub
I am working on a way to generate a list based on the value of each row in a given column (G). Currently the list can copy entire rows and works perfectly. It pulls all rows if column G contains the required text ("Card") and puts them in a list on another spreadsheet with no gaps.
The problem is that I want the list to only contain information from a few columns in each row containing "Card", not the whole row.
Is there a way to make my code below pull specific cells from a row rather than using the .EntireRow function and copy the whole row?
To clarify, this spreadsheet is updated regularly by multiple different users so the information is not static. Rows are added and changed frequently and occasionally deleted. As such I cannot just copy cell values from the original sheet to the new list.
Sub AlonsoApprovedList()
Dim cell As Range
Dim NewRange As Range
Dim MyCount As Long
Dim ExistCount As Long
ExistCount = 0
MyCount = 1
'----For every cell in row G on the ESI Project Data sheet----'
For Each cell In Worksheets("ESI Project Data").Range("G6:G5000")
If cell.Value = "Card" Then
ExistCount = ExistCount + 1
If MyCount = 1 Then Set NewRange = cell.Offset(0, -1)
'----Sets up a new range to copy all data from the row if column G in that row contains the value in question----'
Set NewRange = Application.Union(NewRange, cell.EntireRow)
MyCount = MyCount + 1
End If
Next cell
If ExistCount > 0 Then
NewRange.Copy Destination:=Worksheets("Alonso Approved List").Range("A3")
End If
End Sub
Additional information:
Column G drop down data validation lists containing one several
items. A complete list is in a different worksheet. Users go in to
each line item and select from a specific category.
The other columns in question contain a line item's name, category
(same as column G), a monetary value, and a date.
The code above loops through a list in the "ESI Project Data" Worksheet and detects rows by the value in cell G. It currently copies the whole row every time a key word is in cell G ("Card") in this example. I am using it to generate individual lists grouped by that key word. I just want it to pull individual cells, not use the .EntireRow function as it currently does. I do not know how to do that.
Thank you for your time!
Untested...
Sub AlonsoApprovedList()
Dim cell As Range
Dim rngDest As Range
Dim i As Long
Dim arrColsToCopy
arrColsToCopy = Array(1, 3, 4, 5)
'----For every cell in row G on the ESI Project Data sheet----'
Set rngDest = Worksheets("Alonso Approved List").Range("A3")
Application.ScreenUpdating = False
For Each cell In Worksheets("ESI Project Data").Range("G6:G5000").Cells
If cell.Value = "Card" Then
For i = LBound(arrColsToCopy) To UBound(arrColsToCopy)
With cell.EntireRow
.Cells(arrColsToCopy(i)).Copy rngDest.Offset(0, i)
End With
Next i
Set rngDest = rngDest.Offset(1, 0) 'next destination row
End If
Next cell
Application.ScreenUpdating = True
End Sub
hello is there a code that I can use to copy specific cells to another workbook by clicking a button.
here's what I am trying to do,
from workbook 1 I need to copy info from the following cells
I have Column B info on cell A40 to A69
I have Column B info on cell b2, b3, b4, b8,9,10,11,12,13,14,15 and b40 to b69
I have column D info on cells b2,
I have column G info on cell b1,b2,b3,b4
all this I need to send it to workbook2 which has the same cells assigned to this specific info.
hope I made my self clear.