In sheet 2 of my workbook, I have names of employees, the dates they came into work, the shifts they worked, and absenteeism. In sheet 1 of my code, I have a lookup sheet where I intend for the employee's name to be typed into a cell and to show all the dates and this person worked, along with the shift and absenteeism into the lookup sheet. I've tried a vriaty of things, but this is my current code:
Private Sub worksheet_change(ByVal Target As Range)
Dim Lookup As Worksheet
Dim Data As Worksheet
Dim LastRow As Long
Dim V As Range
Set Lookup = ThisWorkbook.Worksheets("Lookup")
Set Data = ThisWorkbook.Worksheets("Data")
Set V = Lookup.Range("A1:A2")
LastRow = Data.Cells(Rows.Count, "A").End(xlUp).Row
LookupCounter = 2
For i = 2 To LastRow
If Intersect(V, Target) Is Nothing Then
Lookup.Range("B2:C2000").Delete
ElseIf Lookup.Range("A2") = Data.Cells(i, 2) Then
Lookup.Cells(LookupCounter, 2).Value = Data.Cells(i, 1)
Lookup.Range("B2:B2000").NumberFormat = "mm/dd/yyyy"
Lookup.Cells(LookupCounter, 3).Value = Data.Cells(i, 9)
LookupCounter = LookupCounter + 1
End If
Next i
End Sub
My intention is for when a new name is typed, this clears the info from the columns of the lookup page, and inputs the new data for the new name. The second part of my code where I match the names to the dates works, but I am struggling with the clearing function. What can I do to fix it?
Option Explicit
Private Sub worksheet_change(ByVal Target As Range)
Dim Lookup As Worksheet, Data As Worksheet
Dim LastRow As Long, LookupCounter As Long, i As Long
With ThisWorkbook
Set Lookup = .Worksheets("Lookup")
Set Data = .Worksheets("Data")
End With
If Intersect(Lookup.Range("A1:A2"), Target) Is Nothing Then
Exit Sub
Else
' clear sheet
Lookup.Range("B2:C2000").Delete
LastRow = Data.Cells(Rows.Count, "A").End(xlUp).Row
LookupCounter = 2
' get data
For i = 2 To LastRow
If Data.Cells(i, 2) = Lookup.Range("A2") Then
Lookup.Cells(LookupCounter, 2).Value = Data.Cells(i, 1)
Lookup.Cells(LookupCounter, 3).Value = Data.Cells(i, 9)
LookupCounter = LookupCounter + 1
End If
Next
Lookup.Range("B2:B2000").NumberFormat = "mm/dd/yyyy"
End If
End Sub
Related
Im trying to create a table that pulls data from my raw data if certain conditions are met. The code I currently have does not seem to be working.
Public Sub insert_rows()
Dim datasheet As Worksheet
Dim datasheet2 As Worksheet
Dim r As Long
Dim tableA As ListObject
Set tableA = Worksheets(Sheet7).ListObject(Preventable)
Set datasheet = Worksheets(Sheet7)
Set datasheet2 = Worksheets("Data")
With datasheet2
nr = Cells(Rows.Count, 1).End(x1up).Row
For r = 1 To nr
If Cells(r, 17) = "Y" Then
Cells(r, 16).Copy Destination:=Sheets("Sheet7").Range("B4")
End If
Next
End With
End Sub
Basically I have several worksheets and need to pull data from one of them to add to this table in another worksheet. My condition is if the Column in the raw data worksheet contains "Y", then pull cell values into the table of the other worksheet. An image below is an example of the data I want to copy and paste over:
As you can see, they are string values separated by "," and can contain duplicates.
I only want to add just the unique entries into the new table; with no repetition of cells. Anyway I could modify this code to suit those conditions?
You could try something like this:
Public Sub insert_rows()
Dim datasheet As Worksheet
Dim datasheet2 As Worksheet
Dim r As Long, i As Long, nr As Long
Dim tableStartingRow As Long, currenttableitem As Long
Dim stringvalues As Variant
Dim stringseparator As String
Dim valueexists As Boolean
tableStartingRow = 4
stringseparator = ","
Set datasheet = Worksheets("Sheet7")
Set datasheet2 = Worksheets("Data")
With datasheet
currenttableitem = .Cells(.Rows.Count, 2).End(xlUp).Row
End With
With datasheet2
nr = .Cells(.Rows.Count, 16).End(xlUp).Row
For r = 1 To nr
If .Cells(r, 17) = "Y" Then
If InStr(.Cells(r, 16), stringseparator) > 0 Then 'If value contains comma
stringvalues = Split(.Cells(r, 16), stringseparator)
For i = LBound(stringvalues) To UBound(stringvalues)
valueexists = False 'Reset boolean
For x = tableStartingRow To currenttableitem
If datasheet.Range("B" & x).Value = Trim(stringvalues(i)) Then
valueexists = True
Exit For
End If
Next x
If Not valueexists Then
currenttableitem = currenttableitem + 1
datasheet.Range("B" & currenttableitem).Value = Trim(stringvalues(i))
End If
Next i
Else
valueexists = False 'Reset boolean
For x = tableStartingRow To currenttableitem
If datasheet.Range("B" & x).Value = .Cells(r, 16).Value Then
valueexists = True
Exit For
End If
Next x
If Not valueexists Then
currenttableitem = currenttableitem + 1
datasheet.Range("B" & currenttableitem).Value = .Cells(r, 16).Value
End If
End If
End If
Next
End With
End Sub
This code will check each value of the cells and will split the contents by ",". Then compare with the content of the table to see if this value is already in there. In case it is not, it will be added, otherwise omitted.
Also, I notice the use of the Cells inside of a With statement. That was making a reference to the active worksheet. To make reference to the item in the With statement, you need to use .Cells
I hope this will help.
I have a simple Userform with two textboxes. User is to enter Part Description in one labelled "Panel ID" and the number of rows that description is to be entered in the same column of the spreadsheet (Quantity). By now, I am OK with adding value in empty row, but got stuck at copying the value to other cells. I have code for copying the value in set range, but cannot find anything that works for what I am looking for. Thanks
Apples Oranges List
Private Sub SubmitBtn_Click()
Dim iRow As Long, C As Long
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Data")
iRow = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
C = QTYBox.Value
With sh
.Cells(iRow, 1) = TxtPanel.Value
End With
End Sub
Private Sub UserForm_Initialize()
'Empty Panel ID cell
TxtPanel.Value = ""
'Empty Quantity cell
QTYBox.Value = ""
'Set focus to panel ID cell
TxtPanel.SetFocus
End Sub
This is code for second problem:
crate form
crate spreadsheet
Private Sub SubmitBtn_Click()
Dim i As Long
Dim sh As Worksheet
Dim lRow As Long
Set sh = ThisWorkbook.Sheets("Data")
lRow = sh.Cells(Rows.Count, 1).End(xlUp).Row
With sh
For i = 2 To lRow
'Criteria search
If .Cells(i, 1).Value = PanelTxt.Value Then
If .Cells(i, 2).Value = IDTxt.Value Then
'Enter date in Crated and Crate #
.Cells(i, 5) = [Text(Now(), "DD-MM-YY HH:MM")]
.Cells(i, 6) = CrateTxt.Value
Exit For
End If
End If
Next
End With
End Sub
I need to be able to compare every cell in 2 worksheets but the data won't always be in the same row as new data is added and exported constantly.
Range on both sheets would be fairly large, so for now I have limited it to A1:AS150. Any instance where a match cannot be found I'd like to highlight the cell.
I have found this, which looks close to what I need but doesn't work (obviously, I have added the Else code in my working example).
Sub test()
Dim varSheetA As Variant
Dim varSheetB As Variant
Dim strRangeToCheck As String
Dim iRow As Long
Dim iCol As Long
strRangeToCheck = "A1:AS150"
' If you know the data will only be in a smaller range, reduce the size of the ranges above.
Debug.Print Now
varSheetA = Worksheets("Sheet1").Range(strRangeToCheck)
varSheetB = Worksheets("Sheet2").Range(strRangeToCheck) ' or whatever your other sheet is.
Debug.Print Now
For iRow = LBound(varSheetA, 1) To UBound(varSheetA, 1)
For iCol = LBound(varSheetA, 2) To UBound(varSheetA, 2)
If varSheetA(iRow, iCol) = varSheetB(iRow, iCol) Then
' Cells are identical.
' Do nothing.
Else
' Cells are different.
' Code goes here for whatever it is you want to do.
End If
Next iCol
Next iRow
To answer 'Foxfire And Burns And Burns' Questions:
Checks: Does Sheet1.Cell$.Value exist in sheet2 but for every cell in the range on both sheets.
Sheet1
A
B
C
Paul
999
ABC111
John
888
ABC222
Harry
777
ABC333
Tom
666
ABC444
Sheet2
A
B
C
Tom
666
ABC444
John
888
ABC222
Harry
777
ABC333
So in these examples:
Search Sheet1.A1 in Sheet 2, IF = Match Then nothing ELSE Highlight Red. Then A2, A3 etc, Then B1, B2 etc, Then C1, C2 etc...you get the gist.
You mention in your VBA code that something will need to be done, but in your example your just mean that a cell will be highlighted.
This is already covered by Excel's conditional formatting feature. You can be conditional formatting on a formula (in your case you might use a Match() function).
I would advise you to start working with a =Match() formula, in order to learn how this works (you might use =MATCH(A1,$B$1:$B$2,0) as an example, the dollarsigns are used for indicating that the lookup values are not to change), do it on different sheets and then try to get conditional formatting working, first basically and then based on your formula.
Sub test()
Dim varSheetA As Worksheet
Dim varSheetB As Worksheet
Dim i As Long
Dim LR As Long
Set varSheetA = ThisWorkbook.Worksheets("Sheet1")
Set varSheetB = ThisWorkbook.Worksheets("Sheet2")
LR = varSheetA.Range("A" & varSheetA.Rows.Count).End(xlUp).Row
For i = 1 To LR 'we start at first row of sheet 1
If Application.WorksheetFunction.CountIf(varSheetB.Range("A:A"), varSheetA.Range("A" & i).Value) = 0 Then varSheetA.Range("A" & i).Interior.Color = vbRed
Next i
'clean variables
Set varSheetA = Nothing
Set varSheetB = Nothing
End Sub
The code will count each single cell value from column A from Sheet 1 and will check if it exists somewhere in column A in Sheet 2. If not, then highligh in red.
Output after executing code with the data example you've posted:
UPDATE": I made a fakedataset. Notice row Captain America. Values from columns A and C are same in both sheets, but different on column B
Sub test()
Dim varSheetA As Worksheet
Dim varSheetB As Worksheet
Dim i As Long
Dim LR As Long
Dim MyPos As Long
Set varSheetA = ThisWorkbook.Worksheets("Sheet1")
Set varSheetB = ThisWorkbook.Worksheets("Sheet2")
LR = varSheetA.Range("A" & varSheetA.Rows.Count).End(xlUp).Row
For i = 1 To LR 'we start at first row of sheet 1
If Application.WorksheetFunction.CountIf(varSheetB.Range("C:C"), varSheetA.Range("C" & i).Value) > 0 Then
'Match found on Column C. Check A and B
MyPos = Application.WorksheetFunction.Match(varSheetA.Range("C" & i).Value, varSheetB.Range("C:C"), 0)
If varSheetA.Range("A" & i).Value <> varSheetB.Range("A" & MyPost.Value Then varSheetA.Range("A" & i).Interior.Color = vbRed
If varSheetA.Range("B" & i).Value <> varSheetB.Range("B" & MyPos).Value Then varSheetA.Range("B" & i).Interior.Color = vbRed
End If
Next i
'clean variables
Set varSheetA = Nothing
Set varSheetB = Nothing
End Sub
Output:
That cell has been highlighet because is different.
Please, note this code will work only if all values in column C are unique.
Here is my code:
Option Explicit
Private Const SHEET_1 As String = "Sheet1"
Private Const SHEET_2 As String = "Sheet2"
Private Const FIRST_CELL As String = "A1"
Private Const MAX_ROWS As Long = 1048576
Private Const MAX_COLUMNS As Long = 16384
Private varSheetA As Worksheet
Private varSheetB As Worksheet
Private last_row As Long
Private last_column As Long
Private sheet1_row As Long
Private sheet1_column As Long
Private sheet2_row As Long
Private row_match As Boolean
Public Sub CompareTables()
Set varSheetA = ThisWorkbook.Worksheets(SHEET_1)
Set varSheetB = ThisWorkbook.Worksheets(SHEET_2)
'Gets the real Table size
For sheet1_row = 1 To MAX_ROWS - 1
If varSheetA.Range(FIRST_CELL).Offset(sheet1_row, 0).Value = vbNullString _
And varSheetB.Range(FIRST_CELL).Offset(sheet1_row, 0).Value = vbNullString Then
last_row = sheet1_row
Exit For
End If
Next
For sheet1_column = 1 To MAX_ROWS - 1
If varSheetA.Range(FIRST_CELL).Offset(0, sheet1_column).Value = vbNullString _
And varSheetB.Range(FIRST_CELL).Offset(0, sheet1_column).Value = vbNullString Then
last_column = sheet1_column
Exit For
End If
Next
'Sets color RED by default on both Tables
Call SetTextRed(varSheetA.Range(FIRST_CELL).Resize(last_row, last_column))
Call SetTextRed(varSheetB.Range(FIRST_CELL).Resize(last_row, last_column))
'Sweeps all existing ROWS on Sheet1
For sheet1_row = 1 To last_row
'Sweeps all existing ROWS on Sheet2
For sheet2_row = 1 To last_row
row_match = True
'Sweeps all existing COLUMNS on Sheet1 and Sheet2
For sheet1_column = 1 To last_column
If varSheetA.Range(FIRST_CELL).Offset(sheet1_row - 1, sheet1_column - 1).Value _
<> varSheetB.Range(FIRST_CELL).Offset(sheet2_row - 1, sheet1_column - 1).Value Then
row_match = False
Exit For
End If
Next
If row_match Then Exit For 'Found and entire match, no need to search more
Next
'Formats as Grren whenever is a Match
If row_match Then
Call SetTextGreen(varSheetA.Range(FIRST_CELL).Offset(sheet1_row - 1, 0).Resize(1, last_column))
Call SetTextGreen(varSheetB.Range(FIRST_CELL).Offset(sheet2_row - 1, 0).Resize(1, last_column))
End If
Next
End Sub
'Sub Function that sets entire row text as RED
Private Sub SetTextRed(ByVal entireRow As Range)
With entireRow.Font
.Color = RGB(255, 0, 0)
.TintAndShade = 0
End With
End Sub
'Sub Function that sets entire row text as GREEN
Private Sub SetTextGreen(ByVal entireRow As Range)
With entireRow.Font
.Color = RGB(0, 255, 0)
.TintAndShade = 0
End With
End Sub
Ideally, what i need is to email the sepcified range rows with "x" in their column, i tried a code and it's working grand but the only problem is that it's sending 3 emails for 3 rows, but i want to send all the records in one email. I was able to do that using a vba code that converts the selected range in HTML and email it out. Now i want to automate the selection part.So basically i need to select the specified range of any row which have "x" in first column.
I tried a code but it's only selecting the last row that contains "x".
Link for the image showing what i am exactly looking for - https://imgur.com/a/Zq97ukL
Sub Button3_Click()
Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim Sheets As Worksheet
Dim r1 As Range
lRow = Cells(Rows.Count, 2).End(xlUp).Row
For i = 2 To lRow
If (Cells(i, 1)) = "x" Then 'change this range
Set r1 = Range(Cells(i, 2), Cells(i, 4))
r1.Select
On Error Resume Next
On Error GoTo 0
Cells(i, 10) = "Selected " & Date + Time 'column J
End If
Next i
ActiveWorkbook.Save
End Sub
jsheeran posted the bulk of this, but deleted his answer because it wasn't finished.
As previously stated, there is probably no reason to select anything.
Sub Button3_Click()
Dim lRow As Long
Dim i As Long
Dim toDate As Date
Dim Sheets As Worksheet
Dim r1 As Range
lRow = Cells(Rows.Count, 2).End(xlUp).Row
For i = 2 To lRow
If Cells(i, 1).Value = "x" Then
Set r1 = Union(IIf(r1 Is Nothing, Cells(i, 2).Resize(, 3), r1), Cells(i, 2).Resize(, 3))
Cells(i, 10).Value = "Selected " & Date + Time
End If
Next i
If Not r1 Is Nothing Then r1.Select
ActiveWorkbook.Save
End Sub
I would like to export data from a consolidated sheet (DATA) to multiple sheets regarding criteria.
I have a total of 13 criteria, each criteria has to be exported in its dedicated sheet.
I'm trying to optimize this macro (only 2 criteria here) because it lag out
Sub copy()
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")
For Each sh In ThisWorkbook.Worksheets
If sh.Name = "S01" Then
i = 2
j = 2
While Not IsEmpty(feuillePrincipale.Cells(i, 1))
If feuillePrincipale.Cells(i, 11).Value Like "S01*" Then
feuillePrincipale.Cells.Rows(i).EntireRow.copy S01Sheet.Rows(j)
j = j + 1
End If
i = i + 1
Wend
End If
If sh.Name = "S02" Then
i = 2
j = 2
While Not IsEmpty(feuillePrincipale.Cells(i, 1))
If feuillePrincipale.Cells(i, 11).Value Like "S02*" Then
feuillePrincipale.Cells.Rows(i).EntireRow.copy S02Sheet.Rows(j)
j = j + 1
End If
i = i + 1
Wend
End If
Next
Application.ScreenUpdating = True
End Sub
If you have any idea, I read I can use Advanced filter but as you guess I'm new in VBA so I'm listening any tips!
Here is the Advanced Filter method you asked for:
Public Sub Christophe()
Const FILTER_COLUMN = 11
Dim i&, rCrit As Range, rData As Range, aShts
aShts = ["SO"&row(1:13)]
Set rData = Sheets("DATA").[a1].CurrentRegion
Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
rCrit(1) = rData(1, FILTER_COLUMN)
For i = 1 To UBound(aShts)
rCrit(2) = aShts(i, 1) & "*"
rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i, 1)).[a1].Resize(, rData.Columns.Count)
Next
rCrit.Clear
End Sub
The execution time should be instantaneous.
Note: this assumes that you do have 13 criteria, each starting with "SO" and that they occupy column 11 of the Data sheet. It also assumes that you already have 13 sheets named SO1... SO13 in the workbook.
UPDATE
Based on new information that the pattern of the criteria can change, please try this version instead. Note, that it assumes that the sheets already exist and that the sheet names match the criteria:
Public Sub Christophe()
Const FILTER_COLUMN = 11
Dim i&, rCrit As Range, rData As Range, aShts
aShts = Array("SO1", "SO2", "ADQ03", "LocS10")
Set rData = Sheets("DATA").[a1].CurrentRegion
Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
rCrit(1) = rData(1, FILTER_COLUMN)
For i = 0 To UBound(aShts)
rCrit(2) = aShts(i) & "*"
rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i)).[a1].Resize(, rData.Columns.Count)
Next
rCrit.Clear
End Sub
Try using an array to set your criteria sheets:
Dim shArray As Variant
Dim shArrayString As String
Dim feuillePrincipale As Excel.Worksheet
Dim i As Long
Dim j As Long
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
j = 1
'// Create array and populate
shArray = Array("S01", "S02", "S03", "S04") '// add as required
'// Create string representation of array
shArrayString = "{"""
For i = LBound(shArray) To UBound(shArray)
shArrayString = shArrayString & shArray(i) & ""","""
Next
shArrayString = Left(shArrayString, Len(shArrayString) - 2) & "}"
'//Start loop
With feuillePrincipale
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If Not Evaluate("ISERROR(MATCH(" & Left(.Cells(i, 11), 3) & "," & shArrayString & ",0))") Then
.Rows(i).Copy Sheets(shArray(WorksheetFunction.Match(Left(.Cells(i, 11), 3), shArray, 0))).Cells(j, 1)
j = j + 1
End If
Next
End With
It's a bit unclear because if you follow the code you've posted - it's actually just copying and pasting data to the same sheet...
Yes, you should use an autofilter and use a special select to get only the visible cells.
If you want the loop method, you should loop through each row on sheets("DATA") and use a Select Case Statement to decide onto which sheet the data is placed.
By looping through each sheet you are adding loops that will slow it down.
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim cel As Range
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")
For Each cel In feuillePrincipale.Range(feuillePrincipale.Range("A1"), feuillePrincipale.Range("A1").End(xlDown))
Select Case Left(cel.offset(,10).value, 3)
Case "S01"
j = S01Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S01Sheet.Rows(j)
Case "S02"
j = S02Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S02Sheet.Rows(j)
'Case .... keep adding select statement till you get to the last condition
Case Else
End Select
Next cel
Application.ScreenUpdating = True