I am trying to make a VBA code which matches at least 2 criteria.
I would like to return rows where in column C there is "ACMA" and in column T is "0".
It should be listed as below in other sheet:
I tried every formulas on the internet and other users' codes but it does not work. Can you please provide me on a proper way?
Like #CLR mentioned you'll need to check if column T is returning 0 because it's blank or because it's actually 0. For this solution I checked the length of the value in the cell <> 0 (i.e. blank).
Sub ReturnMatches()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastRow1 As Long, newRow2 As Long
Dim x As Long
'don't know the names of your sheets so adjust accordingly
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
'determine last row of data sheet
lastRow1 = ws1.Cells(ws1.Rows.Count, 3).End(xlUp).Row
For x = 2 To lastRow1
'check to see if it is a match
'for T, also check length of value in cell <> 0 (i.e. blank)
If _
ws1.Cells(x, 3) = "ACMA" And _
ws1.Cells(x, 20) = 0 And Len(ws1.Cells(x, 20).Value) <> 0 Then
'define first blank row of 2nd sheet
newRow2 = ws2.Cells(ws1.Rows.Count, 1).End(xlUp).Row + 1
'copy matching information to first blank row
ws2.Cells(newRow2, 1) = "ACMA"
ws2.Cells(newRow2, 2) = ws1.Cells(x, 4)
End If
Next x
End Sub
Related
I have a worksheet of data that has four columns. I want the spreadsheet to add 3 rows after each group based on column D. Column D has the department for the transactions. All department transactions are listed in a row. So Excel just needs to find the change in department and enter three rows after that section.
I have tried this code I found here. It puts a row after every line it sees the department in.
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("IMPORT-WIP") 'better define by name: ThisWorkbook.Worksheets("MySheet")
Dim LastRow_f As Long
LastRow_f = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
ws.Range("A1:D" & LastRow_f).AutoFilter Field:=12, Criteria1:="HR DEPARTMENT"
Dim FilteredData As Range
Set FilteredData = ws.Range("D2:D" & LastRow_f).SpecialCells(xlCellTypeVisible)
Dim iArea As Long
Dim iRow As Long
For iArea = FilteredData.Areas.Count To 1 Step -1 'loop from last to first area
For iRow = FilteredData.Areas(iArea).Rows.Count To 1 Step -1 'loop from last row to first row in each area
With FilteredData.Areas(iArea).Rows(iRow) '<-- this represents the current row we are in the loop
.Offset(RowOffset:=1).EntireRow.Insert Shift:=xlDown
.Offset(RowOffset:=1).EntireRow.Interior.Color = RGB(192, 192, 192)
End With
Next iRow
Next iArea
'remove filters
ws.Range("A1:D" & LastRow_f).AutoFilter
This code will insert 3 rows between groups of values (even unique values). The data does not need to be filtered. It will loop through Column D, test the cell above the current cell and, if not the same value, will insert 3 rows between them. You may have to sort the data first, depending on what you want.
Sub InsertRowsBetweenGroups()
Dim ws As Worksheet, lr As Long, i As Long
Set ws = ThisWorkbook.Sheets("Sheet1") 'Change as needed
lr = ws.Cells(ws.Rows.Count, 4).End(xlUp).Row
For i = lr - 1 To 2 Step -1
If Cells(i, "D") <> Cells(i - 1, "D") Then
Cells(i, "D").Resize(3).EntireRow.Insert Shift:=xlDown
End If
Next i
End Sub
Hoping you can help, please!
So I have 2 worksheets, 1 & 2. Sheet1 has already existing data, Sheet2 is used to dump raw data into. This is updated daily, and the data dump includes both data from previous days, as well as new data. The new data may include rows relating to interactions that may have happened earlier in the month, not just the previous day. So the data is not "date sequential".
There are 9 columns of data, with a unique identifier in column I.
What I'm needing to happen is when running the macro, it looks in column I in Sheet1 and Sheet2, and only copies and pastes rows where the unique identifier in Sheet 2 doesn't already exist in Sheet1. And pastes them from the last empty row onwards in Sheet1.
What I currently have is this - it's all I could find online:
Sub CopyData()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim rng As Range
Dim foundVal As Range
For Each rng In Sheets("Sheet2").Range("A1:I" & LastRow)
Set foundVal = Sheets("Sheet1").Range("I:I").Find(rng, LookIn:=xlValues, LookAt:=xlWhole)
If foundVal Is Nothing Then
rng.EntireRow.Copy Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End If
Next rng
Application.ScreenUpdating = True
End Sub
But it's just not working - not only does it not recognise if the value in column I already exists, it's copying and pasting only the first 2 rows from Sheet2, but duplicating them 8 times each!
Apologies in advance, I'm a real VBA novice, and just can't work out where it's all going wrong. I would appreciate any assistance!
This will do what you want:
Sub testy()
Dim wks As Worksheet, base As Worksheet
Dim n As Long, i As Long, m As Long
Dim rng As Range
Set wks = ThisWorkbook.Worksheets(2) 'Change "2" with your input sheet name
Set base = ThisWorkbook.Worksheets(1) 'Change "1" with your output sheet name
n = base.Cells(base.Rows.Count, "A").End(xlUp).Row
m = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row
For i = 2 To m
On Error Resume Next
If IsError(WorksheetFunction.Match(wks.Cells(i, 9), base.Range("I:I"), 0)) Then
Set rng = wks.Cells(i, 1).Resize(1, 9) 'Change 9 with your input range column count
n = n + 1
base.Cells(n, 1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
End If
Next i
End Sub
I have a workbook of ten sheets. In sheet 1, I want to list out sheet names (sheets 3 thru 10), column heading values in the sheet (columns 8 and beyond only) and for that column the number of cells that have data in it.
My code works for two of these three requirements. On my sheet 1 (named: SheetName Columns) I get the Sheet Names in column A and Column Heading in column B, however not having any luck getting that sheet/columns number of data rows.
On my sheet 1, column A gets duplicated per number of columns after column 7 on that sheet and that is fine.
Sub ListColumnHeadings()
Dim cNbrs As Long, i As Integer, tr As Long, tc As Long, wst As Worksheet
Dim charList(300, 300) As String
Dim ws As Worksheet, OutputRow As Long
Dim myRange As Range
Dim NumRows As Integer
Dim colNbr As Range
Set shSkip1 = ThisWorkbook.Sheets("SheetName Record Cnt")
Set shList = ThisWorkbook.Sheets("SheetName Columns")
OutputRow = 1
On Error Resume Next
For Each ws In Worksheets
If ws.Name <> shList.Name And ws.Name <> shSkip1.Name Then
cNbrs = ws.Range("A1").CurrentRegion.Columns.Count
For i = 8 To cNbrs
shList.Cells(OutputRow, "A").Value = ws.Name
shList.Cells(OutputRow, "B").Value = ws.Cells(1, i)
Set myRange = ws.Columns(i).Select
NumRows = ws.Application.WorksheetFunction.CountA(myRange)
If NumRows > 0 Then
shList.Cells(OutputRow, "C").Value = NumRows
End If
OutputRow = OutputRow + 1
Next i
End If
Next ws
End Sub
It's because of your use of Set myRange... You don't need to .Select it. Just change that line to Set myRange = ws.Columns(i)
If you want to leave .Select, then the next line should be
NumRows = ws.application.worksheetfunction.counta(selection), but it is highly recommended you avoid using .Select, this is just for your info.
So I have a workbook with two sheets in it. I need to copy data from worksheet 2 ("Detail") to worksheet 1 ("Syncrofit"). The items from ws2 I need to paste into progressive rows on sheet 1, so rows in sheet two, column B which say "Joint1-1" need to be inserted below row 1 on sheet 1. This essentially creates a nested table.
Here's what I have so far, mostly scraped together from code and help I've found around here:
Sub SelectJoints()
Sheets("Detail").Activate
Dim Selection1 As Integer, Selection2 As Integer
Dim SelectionRange As Range
Dim num As Integer
Dim rngFind As Range
Set rngFind = Columns("B:B").Find(what:="*" & "Joint1-" & num, After:=Range("B1"), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not rngFind Is Nothing Then
Selection1 = rngFind.Row + 1
End If
Set rngFind = Columns("B:B").Find(what:="*Joint1-" & num + 1, After:=Range("B1"), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not rngFind Is Nothing Then
Selection2 = rngFind.Row - 1
End If
If Selection1 > 0 And Selection2 > 0 Then
Set SelectionRange = Range(Cells(Selection1, 2), Cells(Selection2, 6))
End If
End Sub
The intent here is that this should activate the detail sheet, find strings in column B which match SomeTextHere(Joint1-1) and select those rows. I then need it to paste those selections over to sheet 1 (below row 1, which has a value matching the Joint value in one of the columns), come back to sheet 2, select the rows containing SomeTextHere(Joint1-2) and paste those below the next row (after those which were just inserted). I realize that the pasting part of that is not in the code. This has been driving me nuts.
Please excuse my lack of knowledge in regards to VBA.
I'd like the finished product to look like a nested table kind of like follows:
Original Items
Copied from sheet 2
Copied from sheet 2
Copied from sheet 2
Original Item 2
Copied from sheet 2
etc.
I was a bit bored so I whipped up something that might help you. Let me know if it works for you.
Sub Macro1()
Dim i, j, x
Dim rng As Range
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Sheets("Syncrofit")
Set sh2 = Sheets("Detail")
lr = sh2.Range("B" & Rows.Count).End(xlUp).Row
lc = sh2.Cells(2, Columns.Count).End(xlToLeft).Column
j = 2
For y = 1 To 3 ' set upper limit of first integer in Joint string
For x = 1 To 2 ' set upper limit of second integer in Joint string
For i = 2 To lr
If InStr(sh2.Cells(i, 2), "Joint" & y & "-" & x) <> 0 Then
sh2.Range(sh2.Cells(i, 1), sh2.Cells(i, lc)).Copy
sh1.Rows(j).Insert
j = j + 1
End If
Next i
Next x
Next y
End Sub
I have an Excel worksheet ("All Documents") that is populated from a SharePoint list but also has some columns that contain formulas. I have another worksheet in the same workbook ("Original") that contains the original values of the list items. I need to compare the two worksheets and if the value in column A in "All Documents" does not exist in column A in "Original" it needs to copy the row to the "Original" sheet. It must be pasted as values. I have searched many forums and tried many suggestions but none worked. This is my latest attempt. Any assistance will be appreciated!
Dim x As Long, y As Long, a As Long
Dim b As String
Dim rFound As Range
Dim TargetRange As Range
x = Worksheets("All Documents").Range("A" & Rows.Count).End(xlUp).Row
For a = 2 To x
y = Worksheets("Original").Range("A" & Rows.Count).End(xlUp).Row
b = Worksheets("All Documents").Range("A" & a)
If a > y Then Exit For
With Worksheets("Original").Range("A:A")
Set rFound = .Find(b, LookIn:=xlValues)
If rFound Is Nothing Then
TargetRange = Worksheets("Original"1).Cells(Worksheets("Original").Rows(y + 1))
Worksheets("All Documents").Rows(a).Copy
TargetRange.PasteSpecial xlPasteValues
End If
End With
Next a
Three things,
To set a range you need to:
Set TargetRange = Worksheets("Original").Rows(y + 1)
Check to see if the sheet is ment to be "Original"1 or "Original"
And an improvement copy your values by:
Worksheets("Original").Rows(y + 1).Value = _
Worksheets("All Documents").Rows(a).Value