Im trying to create a form where I can fill in 10 variables into an input table, and this will populate an output table depending on combinations of inputs. I have written some code that i cannot for the life of me figure out why it wont work. My input table, table1, has 2 columns and 10 rows, and my output table has 3 columns and 20 rows.
This is the code so far. It is a basic start to try and get at least the first output to work, and will then be developed to include all variables.
Sub SelectInputsAndOutputs()
Dim tbl1 As Table, tbl2 As Table
Dim rng As Range
Dim row As Long, col As Long
Dim input1 As String, input2 As String
' Set tbl1 to the first table in the document
Set tbl1 = ActiveDocument.Tables(1)
' Set tbl2 to the second table in the document
Set tbl2 = ActiveDocument.Tables(2)
' Loop through each row in tbl1
For row = 1 To tbl1.Rows.Count
' Set rng to the second cell in the current row
Set rng = tbl1.Cell(row, 2).Range
' Read the input value from rng and store it in the appropriate variable
If row = 1 Then
input1 = rng.Text
ElseIf row = 2 Then
input2 = rng.Text
End If
Next
' Calculate the output value based on the inputs
Dim output As String
If input1 = "PiP" And input2 = "CMn" Then
output = "Min:11.7"
ElseIf input1 = "PiP" And input2 = "13Cr" Then
output = "13Cr is the best"
End If
' Write the output value to the third column of tbl2
tbl2.Cell(1, 3).Range.Text = output
End Sub
Basically, nothing happens. My Tables look like this:
---------------------
:Type :PiP :
------------------
:Design : 13Cr :
-------------------
and so on.....
My output table is just a blank 3x20 table.
Related
It is above my possibilities.
I know how to create Vba code with Vlookup or Hlookup for single comparision. However whatIi am trying is beyond my knowledge.
I need to compare 2 tables. 1st is requirements where 2nd is DB extract.
Both tables contains same "Action" column and other columns with Employer role as a header. Values from Action column for both tables are the same however in different order ( Those values need to act as primary key).
Columns with Employer role as a header - same header value for both tables - however columns in different order.
Amount of columns with Employer role as a header is not constants and it gets change every time I get this files. Those columns in extract are in different order than in requirements.
Amount of values from "Action" columns ( primary key) also not constants and change every time I receive files. So I cannot set specific range.
Example of Requirements table
Example of Extract table
Example of what is expected
New target worksheet need to be created where Comparison table will be created.
VBA to create Comparison table in newly created worksheet.
This table should have "Action" column + all columns with Employers role as header form requirements + all columns with Employers role as header form extract set in same order like columns in requirements + comparison table which compare values between Employers roles from Requirements and Extract and show values YES or NO
Try the next code, please. It will return in a newly created sheet (after the last existing). The new file is named "New Sheet". If it exists, it is cleared and reused:
Sub testMatchTables()
Dim sh As Worksheet, sh1 As Worksheet, shNew As Worksheet
Dim tbl1 As ListObject, tbl2 As ListObject, rightH As Long
Dim arrR, arrE, arrH1, arrH2, arrFin, i As Long, j As Long, k As Long
Dim first As Long, sec As Long, refFirst As Long, refSec As Long
Set sh = Set sh = Worksheets("Requirements")'use here the sheet keeping the first table
Set sh1 = Worksheets("Extract Table") 'use here your appropriate sheet
Set tbl1 = sh.ListObjects(1) 'use here your first table name (instead of 1)
Set tbl2 = sh1.ListObjects(1) 'use here your second table name (instead of 1)
arrR = tbl1.Range.value 'put the table range in an array
arrE = tbl2.Range.value 'put the table range in an array
'working with arrays will condiderably increase the processing speed
ReDim arrFin(1 To UBound(arrR), 1 To UBound(arrR, 2) * 3 + 2) 'redim the array to keep the processing result
'UBound is a property telling the number of array elements
arrH1 = Application.Index(arrR, 1, 0) 'make a slice in the array (1D array), the first row, which keeps the headers
arrH2 = Application.Index(arrE, 1, 0) 'make a slice in the array (1D array), the first row, which keeps the headers
'build the column headers:
For i = 1 To UBound(arrFin, 2)
If i <= UBound(arrH1) Then 'firstly the headers of the first table are filled in the final array
arrFin(1, i) = arrH1(i)
ElseIf refSec = 0 Then 'refSec is the column where a blanck column will exist
first = first + 1 'the code incrementes this variable to allow making empty only for the following row
If first = 1 Then
arrFin(1, i) = Empty: refFirst = i 'make the empty column between the two tables data and create a reference
'to be decreated from the already incremented i variable
Else
arrFin(1, i) = arrH1(i - refFirst) 'place each header column values
If i - refFirst = UBound(arrH1) Then refSec = i + 1 'when the code reaches the end of the first array
'it creates a reference for referencing the second time
End If
Else
sec = sec + 1 'the same philosophy as above, to create the second empty column
If sec = 1 Then
arrFin(1, i) = Empty 'create the empty column (for each processed row)
Else
arrFin(1, i) = arrH1(i - refSec) 'fill the header columns
End If
End If
Next
Dim C As Long, r As Long, eT As Long, T As Long
eT = UBound(arrR) 'mark the ending of the first array (where to be the first empty column)
T = UBound(arrR, 2) * 2 + 2 'mark the begining of the third final array part
'after the second empty column
For i = 2 To UBound(arrR) 'iterating between the first array rows
For j = 2 To UBound(arrE) 'iterating the second array rows
If arrR(i, 1) = arrE(j, 1) Then 'if the both arrays first column matches
arrFin(i, 1) = arrR(i, 1): arrFin(i, T + 1) = arrR(i, 1) 'put the Action values in the first area columns
arrFin(i, eT) = arrR(i, 1) 'put the Action values in the last area column
For C = 2 To UBound(arrR, 2) 'iterate between the array columns
rightH = Application.match(arrR(1, C), arrH2, 0) 'find the match of the first array header in the second one
arrFin(i, C) = arrR(i, C): arrFin(i, C + eT - 1) = arrE(j, rightH) 'place the matching header in the final array
If arrR(i, C) = arrE(j, rightH) Then
arrFin(i, T + C) = "TRUE" 'place 'TRUE' in case of matching
Else
arrFin(i, T + C) = "FALSE" 'place 'FALSE' in case of NOT matching
End If
Next C
End If
Next j
Next i
On Error Resume Next 'necessary to return an error if worksheet "New Sheet" does not exist
Set shNew = Worksheets("New Sheet")
If err.Number = 9 Then 'if it raises error number 9, this means that the sheet does not exist
err.Clear: On Error GoTo 0 'clear the error and make the code to return other errors, if any
Set shNew = Worksheets.Add(After:=Worksheets(Worksheets.count)) 'set shNew as new inserted sheet
shNew.name = "New Sheet" 'name the newly inserted sheet
Else
shNew.cells.Clear: On Error GoTo 0 ' in case of sheet exists, it is clear and the code is made to return errors
End If
'set the range where the final array to drop its values:
With shNew.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2))
.value = arrFin 'drop the array content
.EntireColumn.AutoFit 'AutoFit the involved columns
End With
End Sub
Please, test it and send some feedback.
Edited:
I commented the code as detailed I could. If still something unclear, please do not hesitate to ask for clarifications.
I have data that it's not in a consistent position in the cell, sometimes it has a semicolon, sometimes it is to the right or the left of the semicolon. The end result I'm looking is to have in column B all "students" (defined by not being teacher) and in Column C, all Teachers. If no student or teacher is found, then the corresponding cell should be blank.
Currently I'm doing a text to columns to separate both columns then using the following formulas to have the student and teacher separate:
=IF(SUMPRODUCT(--ISNUMBER(SEARCH({"Arts and Music","Math and Science"},A2)))>0,B2,C2)
=IF(SUMPRODUCT(--ISNUMBER(SEARCH("Teacher",A2)))>0,B2,C2)
I still have to do a manual Find and replace to remove the parenthesis and text and leave only the student/teacher name.
IS there any VBA macro that can help me to get from Column A to my expected result in columns B and C? Thank you.
You can use regular expressions to do this. See this post on how to enable them in excel.
Sub FindStrAndCopy()
Dim regEx As New RegExp
regEx.Pattern = "\s*(\w+)\s*\((.+)\)"
With Sheets(1):
Dim arr() As String
Dim val As String
Dim i As Integer, j As Integer
Dim person As String, teachOrSubject As String
Dim mat As Object
For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row:
val = Cells(i, "A").Value
arr = Split(val, ";")
For j = 0 To UBound(arr):
Set mat = regEx.Execute(arr(j))
If mat.Count = 1 Then
person = mat(0).SubMatches(0)
teachOrSubject = mat(0).SubMatches(1)
If teachOrSubject = "Teacher" Then
Cells(i, "C").Value = person
Else
Cells(i, "B").Value = person
End If
End If
Next
Next
End With
End Sub
The macro splits the string on a semicolon and stores either 1 or 2 substrings in the 'arr' array. It then does a regular expression on each one. If the string inside the parenthesis is "Teacher" then the preceding person's name is stored in column "C" otherwise it's a student and the name is stored in column "B".
I create a button that read all the registers you have on column A
then put the students on column B
then put the Teacher on column C
Check that I used "(Teacher)" to know when a teacher is in the String
I used the sheet Called "Sheet1"
And I don't use the first row because is the header row.
If you have any question please contact me.
Private Sub CommandButton1_Click()
'---------------------------------Variables-----------------------------
Dim total, i, j As Integer
'--------------Counting the number of the register in column A----------
ThisWorkbook.Sheets("Sheet1").Range("XDM1").Formula = "=COUNTA(A:A)"
total = CInt(ThisWorkbook.Sheets("Sheet1").Range("XDM1").Value)
'---------------------Creating arrays to read the rows------------------
Dim rows(0 To 1000) As String
Dim columnsA() As String
'------------Searching into the rows to find teacher or student---------
For i = 2 To total
columnsA = Split(ThisWorkbook.Sheets("Sheet1").Range("A" & i).Value, ";")
first = LBound(columnsA)
last = UBound(columnsA)
lenghtOfArray = last - first
MsgBox lenghOfArray
For j = 0 To lenghtOfArray
If InStr(columnsA(j), "(Teacher)") > 0 Then
MsgBox columnsA(j)
ThisWorkbook.Sheets("Sheet1").Range("C" & i).Value = columnsA(j)
Else
ThisWorkbook.Sheets("Sheet1").Range("B" & i).Value = columnsA(j)
End If
Next j
Next i
'--------------------------------Finishing------------------------------
End Sub
I have a code that allows me to copy and paste thousands of rows of information based on matching IDs. However the code does not seem to run well in a pivot table. In sheet 4, the IDs are put into a pivot table while in sheet 1 the IDs and the information are not in pivot table (Both IDs in sheet 4 and 1 are in the same column which is column A). However, the IDs appeared more than once in sheet 1. Thus, when i try to run the code, it gave an error that said Cannot enter a null value as an item or field name in pivot table report" on the line 'rngTracker.Value = arrT found below.
Sub Sample()
Dim rngTracker As Range
Dim rngMaster As Range
Dim arrT, arrM
Dim dict As Object, r As Long, tmp
With Workbooks("FAST_Aug2015_Segment_Out_V1.xlsm")
Set rngTracker = .Sheets("Sheet4").Range("A5:D43000")
Set rngMaster = .Sheets("Sheet1").Range("A2:C200000")
End With
'get values in arrays
arrT = rngTracker.Value
arrM = rngMaster.Value
'load the dictionary
Set dict = CreateObject("scripting.dictionary")
For r = 1 To UBound(arrT, 1)
dict(arrT(r, 1)) = r
Next r
'map between the two arrays using the dictionary
For r = 1 To UBound(arrM, 1)
tmp = arrM(r, 1)
If dict.exists(tmp) Then
arrT(dict(tmp), 4) = arrM(r, 3)
End If
Next r
rngTracker.Value = arrT 'Error shown on this line'
End Sub
Above is the code that i have and gave error as mention above. Would appreciate any help. Thank you. :) Below is the image of the pivot table in sheet 4. The column header called "Acc Seg" is not part of the pivot table but it is where the data will be paste from sheet 1 when both IDs in sheet 4 and sheet 1 matched.
Option Explicit
Public Sub Sample()
Const T As Long = 43000
Const M As Long = 200000
Dim arrT1 As Variant, arrM1 As Variant, rngT2 As Range
Dim arrT2 As Variant, arrM2 As Variant, dict As Object, r As Long
With Workbooks("TEST2.xlsm") 'get values in arrays
Set rngT2 = .Sheets("Sheet4").Range("D5:D" & T)
arrM1 = .Sheets("Sheet1").Range("A2:A" & M)
arrM2 = .Sheets("Sheet1").Range("C2:C" & M)
arrT1 = .Sheets("Sheet4").Range("A5:A" & T)
arrT2 = rngT2
End With
Set dict = CreateObject("Scripting.Dictionary")
For r = 1 To UBound(arrT1) 'load the dictionary
dict(arrT1(r, 1)) = r
Next r
For r = 1 To UBound(arrM1, 1) 'map between the arrays using the dictionary
If dict.exists(arrM1(r, 1)) Then arrT2(dict(arrM1(r, 1)), 1) = arrM2(r, 1)
Next r
rngT2 = arrT2
End Sub
First question here. I was looking for a way to essentially compare 2 small data sets/tables and look for values in column a of table 1 that are additional or are not present in the 'master' table and include some message in a third column. This is in VBA.
It may be easier to explain what I'm hoping to get as output given 2 example tables.
Table 1 in columns a and b of Sheet1:
A B
a12 horse
b23 dog
f54 cat
Table 2 in columns a and b of Sheet2:
A B
b23 dog
f54 cat
i09 tiger
Desired output:
a12 horse Warning: This is an additional value not present in Table 2
b23 dog
f54 cat
i09 tiger Warning: This value was expected but not present in Table 1
Thanks for the help and let me know if there is additional detail can provide to make this easier to answer
Firstly be aware it is the same problem twice.
You essentially need to scan rows of table A to see if they are in table B. Where they are output the row, where only table A has the row output the row with a message.
So you would do this firstly using table 1 as table A, then again but using table 2 as table B. Adding the output of the second at the end of the first.
It's difficult to advise more without knowing more about your VBA ability.
Also your example provides two columns. Do both columns need to be compared or do you just need to compare one? I have assume both (worst case scenario).
You are really using the UNION set operator to add all unique rows so you might be able to adapt the method used here . You have to adapt it as you want the text that describes which table a row was unique to.
Alternatively, you could do it writing VBA loops which would be something like this (which I think will give you what you need).
Paste this into a new module and run Main(). You will need to define the sheet and ranges.
Option Explicit
Dim s1 As Worksheet
Dim s2 As Worksheet
Dim sOutput As Worksheet
Dim NextOutputRow As Range
Sub CompareTwoTables(TableA As Range, TableB As Range, NameOfTableB As String, OutputIfRowsMatch As Boolean)
Dim TableArow As Long
Dim TableBrow As Long
Dim TableACell As Range
Dim TableBCell As Range
Dim FoundMatchingRow As Boolean
Dim ColumnDifferencesDetected As Boolean
TableA.Parent.Select ' useful for debugging - selects teh sheet
For TableArow = 1 To TableA.Rows.Count
FoundMatchingRow = False
For TableBrow = 1 To TableB.Rows.Count
ColumnDifferencesDetected = False
Set TableACell = TableA.Cells(TableArow, 1)
Set TableBCell = TableB.Cells(TableBrow, 1)
TableACell.Select ' useful for debugging
Debug.Print TableACell.Address, TableBCell.Address ' useful for debugging
If TableACell.Value = TableBCell.Value Then
If TableA.Cells(TableArow, 2) = TableB.Cells(TableBrow, 2) Then
FoundMatchingRow = True
Else
ColumnDifferencesDetected = True
End If
End If
If FoundMatchingRow Or ColumnDifferencesDetected Then
Exit For ' TableBrow
End If
Next TableBrow
If FoundMatchingRow Then
If OutputIfRowsMatch Then
NextOutputRow.Cells(1, 1) = TableA.Cells(TableArow, 1)
NextOutputRow.Cells(1, 2) = TableA.Cells(TableArow, 2)
Set NextOutputRow = NextOutputRow.Offset(1, 0)
End If
ElseIf ColumnDifferencesDetected Then
NextOutputRow.Cells(1, 1) = TableA.Cells(TableArow, 1)
NextOutputRow.Cells(1, 2) = TableA.Cells(TableArow, 2)
NextOutputRow.Cells(1, 2) = "One only one column was the same"
Set NextOutputRow = NextOutputRow.Offset(1, 0)
Else
NextOutputRow.Cells(1, 1) = TableA.Cells(TableArow, 1)
NextOutputRow.Cells(1, 2) = TableA.Cells(TableArow, 2)
NextOutputRow.Cells(1, 3) = "This value was expected but not present in " & NameOfTableB
Set NextOutputRow = NextOutputRow.Offset(1, 0)
End If
Next TableArow
End Sub
Sub main()
Dim Table1 As Range
Dim Table2 As Range
' Three sheets must exist
Set s1 = Worksheets("Sheet1")
Set s2 = Worksheets("Sheet2")
Set sOutput = Worksheets("Sheet3")
Set Table1 = s1.Range("A2:B10") ' Allows for a title row and two columns
Set Table2 = s2.Range("A2:B10")
' Clear any previous output
sOutput.Cells.ClearContents
Set NextOutputRow = sOutput.Range("2:2") ' Allows for a title row
CompareTwoTables TableA:=Table1, TableB:=Table2, NameOfTableB:="Table2", OutputIfRowsMatch:=True
CompareTwoTables TableA:=Table2, TableB:=Table1, NameOfTableB:="Table1", OutputIfRowsMatch:=False
sOutput.Select
MsgBox "Done"
End Sub
Is there a way to merge multiple records then display only the highest value for each column? Example: A2:A25=names, B2=Grade1, C2=Grade2...etc.
First I removed duplicates in case there are exact duplicates. Then I sort on Name.
Can something be added to this code, based on column A-names, to display each name once with the highest value from each column?
=IF(B2="","Empty",IF(B2="High","High",IF(B2="Med","Med",IF(B2="Low","Low",""))))
Data Example
A1:name B1:Grade1 C1:Grade2...etc
A2:Joe B2:High C3:Low
A3:Joe B3:Med C3:High
A4:Dan B4:Low C4:Med
A5:Dan B5:Low C5:Low
__Results: Joe Grade1=high Grade2=high, Dan: Grade1=Low Grade2=Med
Record an Excel macro. Select first column. Click advanced filter.Choose copy to location and select a new column say X. Enable unique filter. Now click Ok. Now look at vba source to get the code to get unique elements in a column. Now assign Low as 0, Med as 1, High as 2 . loop through the rows and find the maximum grade1 , maximum grade2 etc corresponding to each element in column X and populate columns Y,Z etc. As and when you find a new maximum replace the existing. Now you will have the required data in columns X,Y,Z. Loop through them again and display in the format what you needed.
Decided to try VBA code for this one. It's a bit bruitish, but gets the job done.
Took a shortcut and made columns b and c numbers rather than strings. You could do a lookup function on the spreadsheet to make that conversion, or add an extra check in the code.
Sub find_high_values()
' subroutine to find max values of columns b and c against names
' assumes for simplicity that there are no more than 10 rows
' assumes values being checked to be numbers, if they are strings, additional loops would need to be done
Dim sName(10) As String, lBval(10) As Long, lCval(10) As Long 'arrays for original list
Dim iCountN As Integer, iUnique As Integer, iUniqueCount As Integer 'counters
Dim bUnique As Boolean
Dim rStart As Range, rOutput As Range 'ranges on worksheet
Dim lBmax(10) As Long, lCmax(10) As Long, sUniqueName(10) As String 'output arrays
Set rStart = ActiveSheet.Range("d6") 'Cell immediately above the first name in list
Set rOutput = ActiveSheet.Range("j6") 'cell reference for max value list
iUniqueCount = 1
For iCountN = 1 To 10 'set max counters to a min value
lBmax(iCountN) = 0
lCmax(iCountN) = 0
Next
For iCountN = 1 To 10 'step through each original row
sName(iCountN) = rStart.Offset(iCountN, 0).Value
lBval(iCountN) = rStart.Offset(iCountN, 1).Value
lCval(iCountN) = rStart.Offset(iCountN, 2).Value
bUnique = True 'Starter value, assume the name to be unique, changes to false if already in list
For iUnique = 1 To iCountN 'loop to check if it is a new name
If sUniqueName(iUnique) = sName(iCountN) Then bUnique = False
Next
If bUnique Then 'if new name, add to list of names
sUniqueName(iUniqueCount) = sName(iCountN)
iUniqueCount = iUniqueCount + 1
End If
Next
iUniqueCount = iUniqueCount - 1 'make the count back to total number of names found
For iUnique = 1 To iUniqueCount 'loop through names
For iCountN = 1 To 10 'loop through all values
If sName(iCountN) = sUniqueName(iUnique) Then
If lBval(iCountN) > lBmax(iUnique) Then lBmax(iUnique) = lBval(iCountN)
If lCval(iCountN) > lCmax(iUnique) Then lCmax(iUnique) = lCval(iCountN)
End If
Next
Next
'output section
rStart.Resize(1, 3).Select
Selection.Copy
rOutput.PasteSpecial xlPasteValues
For iUnique = 1 To iUniqueCount
rOutput.Offset(iUnique, 0).Value = sUniqueName(iUnique)
rOutput.Offset(iUnique, 1).Value = lBmax(iUnique)
rOutput.Offset(iUnique, 2).Value = lCmax(iUnique)
Next
End Sub