I am new to VBA, and I am looking for a simple VBA code to compare 2 rows and merge/copy data if there is a different in the sheets.
I want to compare column A in sheet 2 with column A in sheet 1.
If the ID in column A is equal to column A in sheet 1, update data in columns B and C with the data from sheet 1.
If the ID from sheet 1 isn’t present in sheet 2, add column A,B,C to sheet 2.
Does above make sense or?
BR
And.
I did not test all scenarios through this. Does something like this work for what you are trying to do? This does make the assumption that there is either 0 or 1 occurrence of the ID in Sheet2. Also, assumes that there are column headers in row 1 and not actual data.
Public Sub CheckSheet2()
Dim source_sheet As Worksheet
Set source_sheet = ActiveWorkbook.Worksheets("Sheet1")
Dim source_last_row As Long
source_last_row = source_sheet.Range("A" & source_sheet.Rows.Count).End(xlUp).Row
Dim target_sheet As Worksheet
Set target_sheet = ActiveWorkbook.Worksheets("Sheet2")
Dim target_last_row As Long
target_last_row = target_sheet.Range("A" & target_sheet.Rows.Count).End(xlUp).Row
Dim source_row As Long
For source_row = 2 To source_last_row
Dim source_str As String
source_str = source_sheet.Range("A" & source_row).Value
Dim found_value As Range
Set found_value = target_sheet.Range("A2:A" & target_last_row).Find(source_str)
If Not found_value Is Nothing Then
target_sheet.Range(found_value.Address).Offset(0, 1).Value = source_sheet.Range("B" & source_row).Value
target_sheet.Range(found_value.Address).Offset(0, 2).Value = source_sheet.Range("C" & source_row).Value
Else
target_last_row = target_last_row + 1
target_sheet.Range("A" & target_last_row).Value = source_sheet.Range("A" & source_row).Value
target_sheet.Range("B" & target_last_row).Value = source_sheet.Range("B" & source_row).Value
target_sheet.Range("C" & target_last_row).Value = source_sheet.Range("C" & source_row).Value
End If
Next source_row
End Sub
You will obviously need to change the values of Sheet1 and Sheet2 to your worksheet names.
before I ran the procedure I had something that looked like this in Sheet1.
And this was in Sheet2 before running the procedure. Notice ID 127 and 128 are missing.
This is what Sheet2 looked like after running the procedure.
Related
I am quite new to VBA so my question may sound silly to some of you.
I have a problem with my code. I am trying to check between 2 sheets(1st: test and 2nd: test data. In the code I am using the code name of the sheets) how may times a criteria/my product is met and based on that number to add that many rows beneath the SKU/product.
What I want to do is, if for my first product/SKU I have stock in 5 different locations, I want to add 5 rows in the first sheet and to see the qty in column D and the location in column E.
TestData tab
The reason why I need to list the quantity in different cells is that the stock is in different locations, so I can not just add in to one cell.
I am also adding screen shots of how my two sheets look like.
I have not add the loop to find the location yet, but I want to understand how to add the rows first.
Sub test()
Dim myrange As Range, testrange As Range, cell As Range, result As Range
Dim i As Long, testlastrow As Long, lastrow As Long
Dim helprng As Range
lastrow = TESTTAB.Range("a" & Rows.Count).End(xlUp).row
testlastrow = TDATA.Range("a" & Rows.Count).End(xlUp).row
Set testrange = TDATA.Range("a2:c" & testlastrow)
Set myrange = TESTTAB.Range("b2:b" & lastrow)
Set result = TESTTAB.Range("d2:e" & testlastrow)
Set helprng = TESTTAB.Range("f2:f" & lastrow)
For Each cell In myrange
For i = 1 To lastrow
If cell.Cells(i, 1) = testrange.Cells(i, 1) Then
result.Cells(i, 1) = testrange.Cells(i, 2)
End If
Next i
Next cell
End Sub
Here is the raw structure you were asking for.
Sub test()
' 011
Dim Rng As Range
Dim Tmp As Variant
Dim Radd As Long ' number of rows to add
Dim R As Long ' row counter
With Tdata
' Range, Cells and Rows Count, all in the same sheet
' exclude caption row(s)
Set Rng = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
End With
Application.ScreenUpdating = False ' speed up the process
With TestTab
' end the loop in row 2 because row 1 might contain captions
' loop bottom to top because row numbers will change
' below the current row as you insert rwos
' column 1 = "A"
For R = .Cells(.Rows.Count, 1).End(xlUp).Row To 2 Step -1
Tmp = .Cells(R, 1).Value
Radd = Application.CountIf(Rng, Tmp)
If Radd > 1 Then
.Range(.Rows(R + 1), .Rows(R + Radd)).Insert
.Cells(R + 1, 1).Value = Radd ' for testing purposes
End If
Next R
End With
Application.ScreenUpdating = True ' now you look
End Sub
As our Evil Blue Monkey has suggested, inserting blank rows and then populating them may not be the most efficient way. You can copy a row and then click Insert to insert the copied data into a new row. Get the syntax from the Macro recorder if it's of interest. It works with the Range object the same way.
I have a UserForm with a single selection ListBox (lstKitResult) that is populated with data from the sheet Kit_database. The user can search using a keyword and only filtered data is displayed. After the user makes a selection I would like to transfer this information to cells B3 and C3 in the sheet Update_kit. The ListBox shows 5 columns but I would like to transfer over values from only 2 of these columns (first two columns). This is the code I am currently using:
Private Sub cmdUpdateKit_Click()
Dim ws As Worksheet
Set ws = Sheets("Update_kit")
Dim nextAvailableRow As Long
Dim i As Long
For i = 0 To lstKitResult.ListCount - 1
nextAvailableRow = ws.range("B" & Rows.count).End(xlUp).Row + 1
ws.range("B" & nextAvailableRow) = lstKitResult.Column(0, i)
ws.range("C" & nextAvailableRow) = lstKitResult.Column(1, i)
Next i
Me.Hide
End Sub
It transfers over all filtered results and all columns from the ListBox to Update_kit rather than just the selection and its associated data. Also, the info is dumped into the empty row rather than cells B3 and C3 as I mentioned.
I'm still fairly new to VBA and cannot figure out where the issue is. Can someone advise how to fix this? Much appreciated.
Am assuming this is a userform?
You can do it thus. Loop through each item until you find the selected one and then transfer the relevant columns (zero-based).
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Set ws = Sheets("Update_kit")
Dim i As Long, nextAvailableRow As Long
nextAvailableRow = ws.Range("B" & Rows.Count).End(xlUp).Row + 1
For i = 0 To Me.lstKitResult.ListCount - 1
If Me.lstKitResult.Selected(i) Then
ws.Range("B" & nextAvailableRow) = Me.lstKitResult.List(i, 0) 'column 1
ws.Range("C" & nextAvailableRow) = Me.lstKitResult.List(i, 1) 'column 2
Exit For 'no need to carry on searching
End If
Next i
End Sub
I'm looking to automate the selective copying and stacking of data from multiple sheets into a single sheet. More specifically, I have 4 columns (M, H, A, & F) from which I need to selectively copy cells based on the same-row value of Column I. E.g. with the below case:
Worksheets 2...N
Column A_____Column F_____Column H_____Column I_____Column M
_#####________AAAAAA______AAAAAA_______Rqrmnt_______Date
_#####________AAAAAA______AAAAAA_______Heading_______Blank
For all rows with column I = Rqrmnt across N worksheets, I need to copy the corresponding values in columns A, F, H, and M into worksheet 1, stacking the imports of each sheet top-to-bottom, e.g.:
Worksheet 2 Column A...Worksheet 2 Column M
Worksheet 3 Column A...Worksheet 3 Column M
...
Worksheet N Column A...Worksheet N Column M
I need to be able to perform limited manipulation on the resulting table, specifically sorting the rows by the value of Column M
As I have several hundred such entries, I would prefer to not build this up by linking cells 1-by-1. Additionally, I would prefer to place the copied pseudo-columns individually (i.e. rearrange them in the order M>H>A>F on the master spreadsheet). I Have the following macro, derived from these posts (thanks to urdearboy's comment below for the second linked post). However, I get a Run-time Error 91 fault when I try to run the macro, and the debugger highlights the identified line below. While this post explains the error itself, I has not helped me solve this problem. I have tried initializing the sourceSheetLastRow to an arbitrary number, and slapping the Set keyword in front of the formula, but to no avail.
Option Explicit
Sub Test()
Dim summarySheetTargetRow As Long
Dim sourceSheetTargetRow As Long
Dim sourceSheetLastRow As Long
Dim sourceSheetIndex As Long
Dim numSheets As Long
Dim wb As Workbook
Dim summarySheet As Worksheet
Dim sourceSheet As Worksheet
Set wb = ThisWorkbook
Set summarySheet = wb.Sheets("Summary Sheet")
numSheets = ThisWorkbook.Sheets.Count `My understanding is that this will return the total number of worksheets in the workbook. However, the sheet index seems to skip the number 5, so this may not be getting me the actual number of sheets
sourceSheetIndex = 6 `First sheet from which I want to pull values. Note that the sheets have inconsistent names, so I'm trying to use the sheet index.
summarySheetTargetRow = 38 `Where I want to start plugging in copied cell values
`Make sure receiving area for copied info is clear
Sheets("Summary Sheet").Range("A38:D1415").ClearContents
For sourceSheetIndex = 6 To numSheets
Set sourceSheet = wb.Worksheets(sourceSheetIndex)
DEBUG THORWS FAULT HERE[
sourceSheetLastRow = sourceSheet.Range("M2:M1000").Find("*", SearchDirection:=xlPrevious).Row `I understand this to return the number of cells in the specified range, starting from the last non-empty cell.
]DEBUG THORWS FAULT HERE
For sourceSheetTargetRow = 2 To sourceSheetLastRow `Start at second row because header rows will never have relevant value
If sourceSheet.Range("I" & sourceSheetTargetRow) = "Text" Then
summarySheet.Range("A" & summarySheetTargetRow) = sourceSheet.Range("A" & sourceSheetTargetRow)
summarySheet.Range("B" & summarySheetTargetRow) = sourceSheet.Range("M" & sourceSheetTargetRow)
summarySheet.Range("C" & summarySheetTargetRow) = sourceSheet.Range("H" & sourceSheetTargetRow)
summarySheet.Range("D" & summarySheetTargetRow) = sourceSheet.Range("F" & sourceSheetTargetRow)
summarySheetTargetRow = summarySheetTargetRow + 1
End If
Next sourceSheetTargetRow
Next sourceSheetIndex
End Sub
When do you copy cells, what conditionals in column I need to be true/false? You could use Union to select multiple rows of cells at once.
Courtesy of help I get from my own company's e-forums and a good bit more work, I have finally gotten my desired output. The below macro will copy data from the identified ranges into a semi-dynamic range in a "Summary Sheet". It requires some knowledge of how the source sheet(s) will be formatted.
Option Explicit
Sub Data_Rollup()
'Object variables, which need to be released from memory at the end.
Dim wb As Workbook
Dim summarySheet As Worksheet
Dim sourceSheet As Worksheet
'Non-object variables
Dim summarySheetTargetRow As Long
Dim sourceSheetTargetRow As Long
Dim sourceSheetLastRow As Long
Dim sourceSheetIndex As Long
Dim numSheets As Long
On Error GoTo Error_Test 'Escape clause
'Initialize objects
Set wb = ThisWorkbook
Set summarySheet = wb.Sheets("Summary Sheet")
'Initialize non-object variables
sourceSheetIndex = 5 'Hard-coded starting point for data pull. This should be greater than the number for the Summary sheet.
summarySheetTargetRow = 38 'Hard-coded starting point for data deposition
numSheets = wb.Sheets.Count 'returns the number of sheets in workbook "wb"
Sheets("Summary Sheet").Range("A38:D1415").ClearContents 'Clears out destination cells in summary sheet
'Main loop
For sourceSheetIndex = 5 to numSheets
Set sourceSheet = wb.Worksheets(sourceSheetIndex)
If Not (sourceSheet.Range("A2:A1000").Find("*", SearchDirection:=xlPrevious) Is Nothing) Then 'Using *If Not (* Is Empty) Then* ensures the code just skips over sheets that don't have the range A2:A1000 populated
sourceSheetLastRow = sourceSheet.Range("A2:A1000").Find("*", SearchDirection:=xlPrevious).Row 'searches through the defined range from the bottom up, and returns the number of the first populated row
For sourceSheetTargetRow = 2 To sourceSheetLastRow 'Start at second row to skip headers
If sourceSheet.Range("I" & sourceSheetTargetRow) = "Text" Then
summarySheet.Range("A" & summarySheetTargetRow) = sourceSheet.Range("A" & sourceSheetTargetRow)
summarySheet.Range("B" & summarySheetTargetRow) = sourceSheet.Range("M" & sourceSheetTargetRow)
summarySheet.Range("C" & summarySheetTargetRow) = sourceSheet.Range("H" & sourceSheetTargetRow)
summarySheet.Range("D" & summarySheetTargetRow) = sourceSheet.Range("F" & sourceSheetTargetRow)
summarySheetTargetRow = summarySheetTargetRow + 1
End If 'best practise is to always have an Else clause, but it isn't technically necessary
Next sourceSheetTargetRow 'Cycles loop to next row down
End If 'best practise is to always have an Else clause, but it isn't technically necessary
Next sourceSheetIndex 'Cycles loop to next worksheet
Exit_Test: 'Deallocates memory for object variables
Set sourceSheet = Nothing
Set summarySheet = Nothing
Set wb = Nothing
Exit Sub
Error_Test
MsgBox Err.Number & "-" & Err.Description
GoTo Exit_Test
End Sub
I'll do my best to explain this. I'm working in a spreadsheet that contains roughly 150 columns and 2,500 rows. In column D, there is an identification number that is unique to that line. I need to filter on that column for a specific ID number (say B5555) then subtract the value in column AH of that row from the values in columns AB, O and M of that row. Then I need to zero out the value in column AH.
Filtering for the ID number is no problem but B5555 could show up in any row. IE, one week it shows up in row 2,300 and the next it is in 1,500, so I can't just make the formula say subtract AH2300 from AB 2300 because the next week that will act on the wrong cells. How do I make the formulas subtract specifically from the line that B5555 shows up in? The code I have so far only filters for that ID number so it isn't much but is shown below. I'm new to VBA os nay help would be much appreciated.
Sub ManualAdjustments()
Dim wbTarget As Workbook
Dim wbThis As Workbook
Dim strName As String
Dim rownum As Integer
Set wbTarget = Workbooks("Weekly Data")
wbTarget.Activate
Worksheets("Raw").Activate
rownum = Application.WorksheetFunction.Match("B5555",
Sheets("Raw").Range("D:D"), 0)
The above code is what I have so far. How do I reference "rownum" in a simple subtraction formula? Would it be: Worksheets("Raw").Range("AHrownum")-Worksheets("Raw").Range("ABrownum")
You could do this as below:
Sub ManualAdjustments()
Dim rownum As Long
Dim ws As Worksheet: Set ws = Worksheets("Raw")
'Get the row number where value "B5555" is found in Column D
rownum = ws.Range("D:D").Find(What:="B5555", Lookat:=xlWhole).Row
'Subtract AH minus AB, O & M
NewValue = ws.Range("AH" & rownum) - ws.Range("AB" & rownum) - ws.Range("O" & rownum) - ws.Range("M" & rownum)
MsgBox "Your New Value is: " & NewValue
End Sub
Slightly different approach:
Sub ManualAdjustments()
Dim wbTarget As Workbook
Dim shtTarget As Worksheet
Dim wbThis As Workbook
Dim strName As String
Dim rownum As Long '<<< safer never to use Integer...
Set wbTarget = Workbooks("Weekly Data")
Set shtTarget = wbTarget.Sheets("Raw")
'no "worksheetfunction" = no runtime error if no match
rownum = Application.Match("B5555", shtTarget.Range("D:D"), 0)
If Not IsError(rowNum) Then '<< test for successful match here
With shtTarget.Rows(rownum)
'Here Range() is *relative to the row*
.Range("C1").Value = .Range("A1").value = .Range("B1").Value
End With
End if
End Sub
Excel 2010. I am trying to write a macro that could copy a set of data multiple times based on criteria on another sheet, but I've been stuck for a long time. I very much appreciate any help that could be offered to help me solve this problem.
Step 1: In the "Criteria" worksheet, there are three columns in which each row contains a specific combination of data. The first set of combination is "USD, Car".
Criteria worksheet
Step 2: Then the macro will move to the Output worksheet (please refer to the below link for screenshots), and then filter column A and B with the first set of criteria "USD" and "Car" in the "Criteria" worksheet.
Step 3: Afterwards, the macro will copy the filtered data into the last blank row. But the tricky part here is that, the filtered data has to be copied two times (as the "Number of set" column in the "Criteria" tab is 3 in this combination, and it doesn't have to copy the data three times since the filtered data would be treated as the first set of data)
Step4: After the filtered data have been copied, the "Set" column D will need to fill in the corresponding number of set that the rows are in. Therefore, in this 1st example, cell D2 and D8 will have "1" value, cell D14-15 will have "2" value, and cell D16-17 will have "3" value.
Step5: The macro will then move back to the "Criteria" worksheet and continue to based on the 2nd set of combination "USD, Plane" to filter the data in the "Output" worksheet. Again, it will copy the filtered data based on the "Number of set" in the "Criteria" worksheet. This process will continue until all the different combinations in the "Criteria" worksheet have been processed.
Output worksheet
Ok sorry for delay, here is a working version
you just have to add a sheet called "BF" because the autofilter count wasn't working properly so I had to use another sheet
Sub testfct()
Dim ShC As Worksheet
Set ShC = ThisWorkbook.Sheets("Criteria")
Dim EndRow As Integer
EndRow = ShC.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To EndRow
Get_Filtered ShC.Cells(i, 1), ShC.Cells(i, 2), ShC.Cells(i, 3)
Next i
End Sub
Sub Get_Filtered(ByVal FilterF1 As String, ByVal FilterF2 As String, ByVal NumberSetsDisered As Integer)
Dim NbSet As Integer
NbSet = 0
Dim ShF As Worksheet
Set ShF = ThisWorkbook.Sheets("Output")
Dim ColCr1 As Integer
Dim ColCr2 As Integer
Dim ColRef As Integer
ColCr1 = 1
ColCr2 = 2
ColRef = 4
If ShF.AutoFilterMode = True Then ShF.AutoFilterMode = False
Dim RgTotal As String
RgTotal = "$A$1:$" & ColLet(ShF.Cells(1, Columns.Count).End(xlToLeft).Column) & "$" & ShF.Cells(Rows.Count, 1).End(xlUp).Row
ShF.Range(RgTotal).AutoFilter field:=ColCr1, Criteria1:=FilterF1
ShF.Range(RgTotal).AutoFilter field:=ColCr2, Criteria1:=FilterF2
'Erase Header value, fix? or correct at the end?
ShF.AutoFilter.Range.Columns(ColRef).Value = 1
Sheets("BF").Cells.ClearContents
ShF.AutoFilter.Range.Copy Destination:=Sheets("BF").Cells(1, 1)
Dim RgFilt As String
RgFilt = "$A$2:$B" & Sheets("BF").Cells(Rows.Count, 1).End(xlUp).Row '+ 1
Dim VR As Integer
'Here was the main issue, the value I got with autofilter was not correct and I couldn't figure out why....
'ShF.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Rows.Count
'Changed it to a buffer sheet to have correct value
VR = Sheets("BF").Cells(Rows.Count, 1).End(xlUp).Row - 1
Dim RgDest As String
ShF.AutoFilterMode = False
'Now we need to define Set's number and paste N times
For k = 1 To NumberSetsDisered - 1
'define number set
For j = 1 To VR
ShF.Cells(Rows.Count, 1).End(xlUp).Offset(j, 3) = k + 1
Next j
RgDest = "$A$" & ShF.Cells(Rows.Count, 1).End(xlUp).Row + 1 & ":$B$" & (ShF.Cells(Rows.Count, 1).End(xlUp).Row + VR)
Sheets("BF").Range(RgFilt).Copy Destination:=ShF.Range(RgDest)
Next k
ShF.Cells(1, 4) = "Set"
Sheets("BF").Cells.ClearContents
'ShF.AutoFilterMode = False
End Sub
And the function to get column letter using an integer input :
Function ColLet(x As Integer) As String
With ActiveSheet.Columns(x)
ColLet = Left(.Address(False, False), InStr(.Address(False, False), ":") - 1)
End With
End Function