I am working on one scenario where I have two sheets. Sheet1 is the master sheet and sheet2 which I am creating.
Column1 of Sheet1 is Object which has duplicate objects as well. So, what I have done is I have created a macro which will produce the unique Objects and will paste it in sheet2.
Now, from Sheet2, each of the objects should be matched with Sheet1 column1 and based on the matching results, it should also count the corresponding entries from other columns in sheet1 to sheet2.
Below are the snapshots of my two sheets
Sheet1
Sheet2
here is my macro code which will first copy and paste the unique objects from sheet1 to sheet2 Column1.
Sub UniqueObj()
Dim Sh1 As Worksheet
Dim Rng As Range
Dim Sh2 As Worksheet
Set Sh1 = Worksheets("Sheet1")
Set Rng = Sh1.Range("A1:A" & Sh1.Range("A65536").End(xlUp).Row)
Set Sh2 = Worksheets("Sheet1")
Rng.Cells(1, 1).Copy Sh2.Cells(1, 1)
Rng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sh2.Range("A1"), Unique:=True
End Sub
But, I am unable to move forward from there. I am pretty new and any help would be very greatful.
Thanks
If I'm understanding what you want correctly, you're just counting matching columns from Sheet1 where the value in the corresponding column isn't blank? If so this should do the trick.
Option Explicit
Sub GetStuffFromSheet1()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lastRow1 As Long, lastRow2 As Long
Dim x As Long
'turn on error handling
On Error GoTo error_handler
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
'determine last row with data in sheet 1
lastRow1 = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
'determine last row with data in sheet 2
lastRow2 = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row
'define columns in sheet 1
Const objCol1 As Long = 1
Const rProdCol1 As Long = 3
Const keysCol1 As Long = 4
Const addKeysCol1 As Long = 5
'define columns in sheet 2
Const objCol2 As Long = 1
Const rProdCol2 As Long = 2
Const keysCol2 As Long = 3
Const addKeysCol2 As Long = 4
'turn off screen updating + calculation for speed
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'loop through all rows of sheet 2
For x = 2 To lastRow2
'formula counts # of cells with matching obj where value isn't blank
ws2.Cells(x, rProdCol2) = WorksheetFunction.CountIfs(ws1.Columns(objCol1), ws2.Cells(x, objCol2), ws1.Columns(rProdCol1), "<>" & "")
ws2.Cells(x, keysCol2) = WorksheetFunction.CountIfs(ws1.Columns(objCol1), ws2.Cells(x, objCol2), ws1.Columns(keysCol1), "<>" & "")
ws2.Cells(x, addKeysCol2) = WorksheetFunction.CountIfs(ws1.Columns(objCol1), ws2.Cells(x, objCol2), ws1.Columns(addKeysCol1), "<>" & "")
Next x
'turn screen updating + calculation back on
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
error_handler:
'display error message
MsgBox "Error # " & Err.Number & " - " & Err.Description, vbCritical, "Error"
'turn screen updating + calculation back on
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
End Sub
In case a non VBA solution works for you, you can resume your data with a Pivot Table, take field Object into rows section and rest of fields into values section (choose Count)
This returns the exact output you are looking for. Easy to update and easy to create.
In case you want a VBA solution, because your design is tabular and you are counting values, you can use CONSOLIDATE:
Consolidate data in multiple worksheets
'change K1 with cell where to paste data.
Range("K1").Consolidate Range("A1").CurrentRegion.Address(True, True, xlR1C1, True), xlCount, True, True, False
'we delete column relation type and column value. This columns depends on where you paste data, in this case, K1
Range("L:L,P:P").Delete Shift:=xlToLeft
After executing code i get this:
Hope this helps
Related
I use the below code in a macro to copy all rows from a "Template" sheet and paste them to the active sheet. Then all except the first of the pasted rows are grouped and "collapsed" i.e RowLevels:=1.
If .Outline.SummaryRow <> xlSummaryAbove Then .Outline.SummaryRow = xlSummaryAbove
csLastRow = copySheet.Cells(Rows.Count, 1).End(xlUp).Row
copySheet.Range("2:" & csLastRow).Copy
.Rows(LRow).PasteSpecial Paste:=xlPasteAll
.Range(.Cells(.Rows.Count, 1).End(xlUp), .Cells(.Rows.Count, 1).End _
(xlUp).Offset(-(csLastRow - 3), 1)).EntireRow.Group
ActiveSheet.Outline.ShowLevels RowLevels:=1, ColumnLevels:=0
This macro is run over and over to create a long list of summary rows with collapsed grouped rows below each as shown in the image.
The intention is to be able to delete a summary row and the collapsed group below it, if no longer needed on the sheet. As expected, when done manually, clicking on the summary row and deleting it, only deletes the summary row and appends the hidden rows below it to an adjacent group.
Is there a way to select the summary row and delete it along with the hidden grouped rows below it? How could I reference the first and last rows of a group in relation to the selected summary row above it in order to delete with vba?
Please, test the next code. Since your picture does not show the columns headers (if any of them is hidden), the code assumes that you want to qualify the group to be deleted according to its cell value in column "B:B" (see strCat value):
Sub DeleteSpecificGroup()
Dim ws As Worksheet, lastRow As Long, firstR As Long, cellC As Range
Dim strCat As String, i As Long, firsGRow As Long, lastGRow As Long
strCat = "Category 3" 'use there the category you need
Set ws = ActiveSheet 'use here the sheet you need
lastRow = ws.Range("A" & ws.rows.count).End(xlUp).row
Set cellC = ws.Range("B2:B" & lastRow).Find(What:=strCat, After:=ws.Range("B2"), _
LookIn:=xlValues, Lookat:=xlWhole)
If Not cellC Is Nothing Then
firsGRow = cellC.row 'first row of the group to be deleted
If ws.rows(cellC.row + 1).OutlineLevel > 1 Then
For i = cellC.row + 1 To lastRow
If ws.rows(i).EntireRow.ShowDetail Then
ws.rows(i).EntireRow.Hidden = False
Else
lastGRow = i - 1: Exit For 'last row of the group to be deleted
End If
Next i
End If
Else
MsgBox strCat & " could not be found in column ""B:B""...": Exit Sub
End If
ws.rows(firsGRow & ":" & lastGRow).EntireRow.Delete
End Sub
Edited:
To delete the group based on the group summary row selection, plese use the next code:
Sub DeleteSpecificSelectedGroup()
Dim ws As Worksheet, lastRow As Long, firstR As Long
Dim i As Long, firsGRow As Long, lastGRow As Long
Set ws = ActiveSheet 'use here the sheet you need
lastRow = ws.UsedRange.Rows.Count
If ws.Outline.SummaryRow <> xlSummaryAbove Then ws.Outline.SummaryRow = xlSummaryAbove
firsGRow = Selection.Row
Application.Calculation = xlCalculationManual
If ws.Rows(firsGRow + 1).OutlineLevel > 1 Then
For i = firsGRow + 1 To lastRow + 500
If ws.Rows(i).EntireRow.ShowDetail And ws.Rows(i).OutlineLevel > 1 Then
ws.Rows(i).EntireRow.Hidden = False
Else
lastGRow = i - 1: Exit For 'last row of the group to be deleted
End If
Next i
End If
ws.Rows(firsGRow & ":" & lastGRow).EntireRow.Delete
Application.Calculation = xlCalculationAutomatic
End Sub
I'm trying to help a colleague with an excel report. He is not very good with computers and is making errors in copying all the relevant data from one sheet to another. He's working with a dataset that looks like this:
] [1]: https://i.stack.imgur.com/dHUpt.png (not allowed to upload images directly yet because i created a new account)
These are pending shipping values and everyday a report is generated with all the orders and the pending ones need to be copied into another sheet and then their status is updated in that excel sheet.
What I need is a solution that when I paste my report into sheet one, I can run a VBA code and compare all the values in column B of sheet one to all the values in column B of sheet two. Then, whatever is not present in column B of sheet two can be highlighted in sheet one or pasted into sheet three/ appended into sheet two. In this way, they operator does not have to do the lookup by himself.
If there is any other solution than VBA that could help, feel free to suggest. Thanks!
You can try this:
Sub CompareData()
Application.ScreenUpdating = False
On Error GoTo 0
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = wb.Worksheets("Sheet1") 'Change Sheet Name
Set ws2 = wb.Worksheets("Sheet2") 'Change Sheet Name
ws1.Copy after:=ws2
Set ws3 = wb.ActiveSheet
Dim LastRow1 As Long
Dim Rng As Range
With ws3
LastRow1 = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("E1").Value = "Vlookup"
.Range("E2").Value = "=VLOOKUP(B2," & ws2.Name & "!B:B,1,0)"
.Range("E2").Copy .Range("E3:E" & LastRow1)
.Range("A1:E1").AutoFilter FIELD:=5, Criteria1:="#N/A"
Set Rng = .AutoFilter.Range.Offset(1, 0)
Set Rng = Rng.Resize(Rng.Rows.Count, 4)
End With
Dim LastRow2 As Long
LastRow2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row
Rng.Copy ws2.Range("A" & LastRow2 + 1 & ":D" & LastRow2 + 1)
Application.DisplayAlerts = False
ws3.Delete
Application.DisplayAlerts = True
ws2.Activate
Exit Sub
0:
MsgBox "Something went wrong"
Application.ScreenUpdating = True
End Sub
Don't forget to change your sheet name.
For such tasks (comparing data in different worksheets), I usually use Excel built-in IF funcion. Example: =IF([Workbook_1]Sheet_1!B1=[Workbook_2]Sheet_2!B1,".",FALSE). Then, just fill down the formula (dragging down).
Note: . is used for easiness of distinguishing FALSE values.
I have an excel sheet named as "Task" which contains two tabs "Data" and "DB-Task". I want to copy data from sheet "Data" to "DB-Task". Sheet "Data" has five columns (e.g. A,B,C,D,E,F). I want that if some one enter data in first row it should be transferred to another tab. If any of the columns is not filled it should give a popup to enter values before transferring data to another sheet . And In case the second row has all data it should get transferred to another sheet and only give error for first row .
I am using below code for copying data and it is successfully copying data from one sheet to another . Now I am not sure how should I use if condition effectively so that I can achieve what I want
Dim sheet1 As Worksheet
Dim sheet2 As Worksheet
Dim endrow As Long
Set sheet1 = ActiveWorkbook.Sheets("Data")
Set sheet2 = ActiveWorkbook.Sheets("Delivery Task")
Application.ScreenUpdating = False
endrow = sheet2.Range("A" & sheet2.Rows.Count).End(xlUp).Row
sheet1.Range("A2:E10").Copy
sheet2.Activate
sheet2.Range("A" & endrow + 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
sheet1.Activate
Range("A2:E10").ClearContents
End Sub
Eventhough I am new to VBA Let me help.You can use this sub to check if all the columns are filled for a particular row and based on the value of column 8 you can copy and transfer file
FindEmptyCells()
Dim colnum As Long
Dim rownum As Long
Dim lastrow As Long
lastrow = Sheets("Data").Range("A" & Rows.count).End(xlUp).Row
For rownum = 1 To lastrow
For colnum = 1 To 5
If IsEmpty(Cells(rownum, colnum)) Then '<== To Check for Empty Cells
Cells(rownum, 8) = "Data Incomplete" '<== To Enter value if empty cell found
Else
Cells(rownum, 8) = "OK"
End If
Next colnum
Next rownum
End Sub
I have an Excel sheet that contains entries for ~150 employees. Each row contains the name as well as hours worked, pay, team, etc etc etc etc. The B column in each row contains the employees name in Last,First format. About half the employees on the sheet are part time employees. What i'm trying to do is write a macro in VB that copies the entire row if the name in the B column matches one of the names of the part time employees so that one of my coworkers can simply run the macro and paste all of the rows of copied users into a new sheet each week. Here's what I currently have. (I have all of the employees names in the array however I have censored them out) I really don't understand much of the last 50% of the code. This stuff was stuff I found online and have been messing around with.
`Sub PartTime()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean
nameArray = Array(NAMES CENSORED)
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add
For I = 1 To NoRows
Set rngCells = wsSource.Range("C" & I & ":F" & I)
Found = False
For J = 0 To UBound(strArray)
Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
Next J
If Found Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub`
This code should work for what you are looking for. It is important to note that the string names in your array must be identical to that in Column B (with the exception of leading and trailing spaces), so if the names are written "LastName, FirstName" then your input data must be identical. This code could be tweaked to not have this requirement, but for now I've left it as such. Let me know if you'd prefer the code be adjusted.
Option Explicit
Sub PartTimeEmployees()
Dim NewSheet As Worksheet, CurrentSheet As Worksheet, NameArray As Variant
Set CurrentSheet = ActiveWorkbook.ActiveSheet
Set NewSheet = Sheets.Add(After:=Sheets(Worksheets.Count))
NewSheet.Name = "Part Time Employees"
NameArray = Array("NAMES CENSORED")
'Pulling headers from the first row
CurrentSheet.Rows(1).EntireRow.Copy
NewSheet.Select 'Redundant but helps avoid the occasional error
NewSheet.Cells(1, 1).Select
ActiveSheet.Paste
CurrentSheet.Select
Dim NextRow As Long
NextRow = 2
'Writing this code to not assume that the data is continuous
Dim Count As Long
'Iterating to the end of the data in the sheet
For Count = 2 To CurrentSheet.UsedRange.Rows.Count
If Not IsEmpty(CurrentSheet.Cells(Count, 2)) Then
For Counter = 1 To UBound(NameArray)
'Performing string operations on the text will be faster than the find method
'It is also essential that the names are entered identically in your array
If UCase(Trim(CurrentSheet.Cells(Count, 2).Value)) = UCase(NameArray(Counter)) Then
CurrentSheet.Rows(Count).Copy
NewSheet.Select
NewSheet.Cells(NextRow, 1).Select
ActiveSheet.Paste
CurrentSheet.Select
NextRow = NextRow + 1
Exit For
End If
Next Counter
End If
Next Count
End Sub
No need to loop through the array if you use a Range.AutoFilter Method with the array as criteria.
See comment for each line of operational code.
Option Explicit
Sub partTimers()
Dim nameArray As Variant
'construct an array of the part-time employees' names
nameArray = Array("Trgh, Evtfk", "Mtre, Sdnrm", _
"Sfgd, Pxduj", "Lsds, Qwrml", _
"Eqrd, Oqtts")
With Worksheets("Sheet1") 'you should know what worksheet the names are on
'turn off AutoFilter is there is one already in operation
If .AutoFilterMode Then .AutoFilterMode = False
'use the 'island' of cells radiating out from A1
With .Cells(1, 1).CurrentRegion
'apply AutoFilter using array of names as criteria
.AutoFilter field:=2, Criteria1:=nameArray, Operator:=xlFilterValues
'check if there is anything to copy
If Application.Subtotal(103, .Columns(2)) > 1 Then
'copy the filtered range
.Cells.Copy
'create a new worksheet
With .Parent.Parent.Worksheets.Add(After:=Sheets(Sheets.Count))
'paste the filtered range, column widths and cell formats
.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
End With
End If
End With
'turn off the AutoFilter
If .AutoFilterMode Then .AutoFilterMode = False
'turn off active copy range
Application.CutCopyMode = False
End With
End Sub
Trying to write a macro in VBA for Excel to look at the value in a certain column from each row of data in a list and if that value is "yes" then it copies and pastes the entire row onto a different sheet in the same workbook. Let's name the two sheets "Data" and "Final". I want to have the sheets referenced so it does not matter which sheet I have open when it runs the code. I was going to use a Do loop to cycle through the rows on the one data sheet until it finds there are no more entries, and if statements to check the values.
I am confused about how to switch from one sheet to the next.
How do I specifically reference cells in different sheets?
Here is the pseudocode I had in mind:
Do while DataCells(x,1).Value <> " "
for each DataCells(x,1).Value="NO"
if DataCells(x,2).Value > DataCells(x,3).Value or _
DataCells(x,4).Value < DataCells(x,5).Value
'Copy and paste/insert row x from Data to Final sheet adding a new
'row for each qualifying row
else
x=x+1
end
else if DataCells(x,1).Value="YES"
Loop
'copy and paste entire row to a third sheet
'continue this cycle until all rows in the data sheet are examined
Sub FilterAndCopy()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim sh As Worksheet, sh2 As Worksheet
Dim lastrow1 As Long
Dim lastcolumn1 As Long
Set sh = ThisWorkbook.Sheets("Data")
Set sh2 = ThisWorkbook.Sheets("Final")
lastrow1 = sh.Cells(Rows.Count, "A").End(xlUp).Row ' Replace "A" With column that has the most Rows
lastcolumn1 = sh.Cells(1, Columns.Count).End(xlToLeft).Column
With sh.Range(.Cells(1, 1), .Cells(lastrow1, lastcolumn1))
'Replace the number in the field section with your Columns number
.AutoFilter , _
Field:=1, _
Criteria1:="yes"
.Copy sh2.Range("A1")
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub