So I have several worksheets on the same Excel workbook that I need to compare. Worksheet 1 is the masterlist, and I need to compare worksheets 1-2, 1-3, 1-4. I then need to paste any similar 1-2 data cells in column A of worksheet 5, and similar 1-3 data cells in column B of worksheet 5, and 1-4 similarities to column C of worksheet 5. For starters I have focused on getting the 1-2 comparison to work. So far I have been able to get my test number to be pasted to cell A1 of sheet 5. I am running into trouble because it only works for 1 cell, and I cannot get the program to paste a similarity in A1, and then A2... etc, when I have multiple similar items. They just overwrite each other in cell A1, or in the entire A column. I am also running into trouble because the program as it is written stops when it hits a blank space, but I need it to just skip the blanks and read the next cell when it comes across them. This is because my data sheets are very messy and the data is scattered over several thousands of rows among several different columns, with spaces randomly interjected. Below is my working code for just reading a similarity, and pasting it into A1. I should note that I have considered adding a specific cell range depending on which sheet I am on in order to put an end point on the program, but I haven't quite figured out how to work it in.
Sub findDuplicates()
' code to find duplicates in 2 different worksheets
Dim rng1, rng2, rngA, cell1, cell2 As Range
' 4 ranges have been defined
Set rng1 = Sheets("Sheet1").Range("C:C")
'rng1 defines the existing data in column C and worksheet1
Set rng2 = Sheets("Sheet2").Range("C:C")
'rng2 defines the data in column C and worksheet2
Set rngA = Sheets("Sheet5").Range("A1")
For Each cell1 In rng1
If IsEmpty(cell1.Value) Then Exit For
'check for empty rows. If true then exit the program
For Each cell2 In rng2
If IsEmpty(cell2.Value) Then Exit For
If cell1.Value = cell2.Value Then
'compare data in cell1 and cell2 and then copy/paste if they have equal values
cell1.Copy
Sheets("Sheet5").Select
rngA.Select
ActiveSheet.Paste
End If
'run the looping process
Next cell2
Next cell1
End Sub
The general idea of what I imagine the program to look like would be something like
Define ranges
Block of code that runs through each cell in sheet 1 comparing it to all cells in sheet 2.
Block of code that, when similarities are found, copy/paste that cell on sheet 1 to sheet 5 column A
*Program resumes scan from the next cell on sheet 1*
Block of code that breaks the program when it hits the end of the specified cell range
Any help with this would be greatly appreciated! You would be saving me at least a week's worth of mindless work.
A few comments about your code:
Dim rng1, rng2, rngA, cell1, cell2 As Range means only cell2 is defined As Range, while rng1, rng2, rngA, cell1 defined As Variant
You don't need to have 2 For loops to compare, you can replace the second For loop with the Match function, it will save you precious run-time.
You need to find the next empty row in "Sheet5", by using NextRow = Sheets("Sheet5").Cells(Sheets("Sheet5").Rows.Count, "A").End(xlUp).Row + 1
Last, you don't need to Select the sheets in order to copy>>paste, you can so it in 1-line (see in my code below).
Code
Sub findDuplicates()
' code to find duplicates in 2 different worksheets
' 4 ranges have been defined
Dim rng1 As Range, rng2 As Range, rngA As Range, cell1 As Range, cell2 As Range
Dim NextRow As Long
'rng1 defines the existing data in column C and "Sheet1"
Set rng1 = Sheets("Sheet1").Range("C:C")
'rng2 defines the data in column C and "Sheet2"
Set rng2 = Sheets("Sheet2").Range("C:C")
Set rngA = Sheets("Sheet5").Range("A1")
For Each cell1 In rng1
If Not IsEmpty(cell1.Value) Then ' only check non-empty cells
If Not IsError(Application.Match(cell1.Value, rng2 , 0)) Then ' <-- confirm match was asuccessful
' find next empty row in column "A" in "Sheet5"
NextRow = Sheets("Sheet5").Cells(Sheets("Sheet5").Rows.Count, "A").End(xlUp).Row + 1
' Copy >> Paste in 1 line (without need to Select the Sheets)
cell1.Copy Destination:=Sheets("Sheet5").Range("A" & NextRow)
End If
'run the looping process
End If
Next cell1
End Sub
Your problem is that rngA points to A1 and nothing changes that.
Add one line after your paste command:
ActiveSheet.Paste
Set rngA = rngA.Offset(1,0) ' This will move the pasting location one step down
Related
I'm pretty new to VBA, I've got a spread sheet that has a list of vehicle ID's in a row of columns, and different identifiers (ID) in column A.
So far I'm able to search for the sheet with the vehicle name and copy a range of cells to the main sheet. I'm trying to make it so that once it finds the specific vehicle sheet, it looks for the specific ID and pulls that in, rather than copy a set range of cells. I'm having it return nothing now, and when I had it before excel would crash, so I assumed I was in some sort of endless loop.
Dim ws As Worksheet, sh As Worksheet
Dim Rng As Range, c As Range
Dim ECU_Ovv As Range, ECU_V As Range
Set ws = Sheets("Overview") 'main worksheet to copy everything to
Set Rng = ws.Cells(3, 3).Resize(3, LastColumn) ' I;ve calculated LastColumn earlier, it's defined as a Long
Set ECU_Ovv = ws.Cells(5, 2).Resize(LastRow, 2)
For Each sh In Sheets
For Each c In Rng.Cells
If sh.Name = c Then
'Find row range for specific vehicle
LastRow = sh.Cells(Rows.Count, 2).End(xlUp).Row
Set ECU_V = sh.Cells(5, 2).Resize(LastRow, 2) ' this is the only syntax I could figure out to get it to let me set a range with a calculated variable
For Each ECU_Ovv In ECU_V.Cells 'now look for the ID in the specific sheet
If ECU_Ovv.Cells = ECU_V.Cells Then
a = ECU_Ovv.Value 'Put this here to see if I am able to match ID's from the main sheet to the specific sheet
'sh.Range("D12:D47").Copy Destination:=ws.Cells(24, c.Column) 'this was working but it's hardcoded so any change in the sheets would break it
End If
Next ECU_Ovv
End If
Next c
Next sh
I'm planning on adding a copy cell, 2 columns over (from the found ID) to the column of the vehicle (Rng), but I'll cross that bridge when I get there!
I have a farily large database of around 2000 people, sheet1 has all of their names and relevant details. Sheet 2 has data pulled on from a site. I would like the data from sheet 2 to auto populate the cells in Sheet 1. Also if the person does not exist in sheet1 to highlight the data it couldnt do. I am so stuck on this.
Sub dup()
Dim cell As Range, cella As Range, rng As Range, srng As Range
Set rng2 = Sheets(2).Range("A2:E2000")
Set rng3 = Sheets(3).Range("A2:E29000")
For Each cell In rng2
For Each cella In rng3
If cella = cell Then
cella.Interior.ColorIndex = 6
' cella.AddComment.Text Text:="duplicate value"
End If
Next cella
Next cell
Set rng2 = Sheets(2).Range("T2:Y2000")
Set rng4 = Sheets(4).Range("A1:F2000")
For Each cell In rng2
For Each cella In rng4
If cella = cell Then
cella.Interior.ColorIndex = 6
' cella.AddComment.Text Text:="duplicate value"
End If
Next cella
Next cell
End Sub
Its hard for me to show as it has a lot of columns not sure how on earth i can show you what im trying to do? :(
Try https://filetea.me/t1sfGPWECvdQqmgVDGtXL4oRQ
Maybe, if you want to do it without vba, you could use the LOOKUP function in the sheet 1's auto populate column. It works like that:
=LOOKUP(sheet1!A2, sheet2!table[a], sheet2!table[b])
This will find the value in the column "b" of the table in sheet2 based on the values of column "a". This will chose the value in the same row were column "a" matches the value in sheet1's A column. Let me know if I wasn't clear enough here.
Then you can use Conditional Formatting rules for the highlight you said. I suggest the COUNTIF function, that will return 0 if no matching value is found in the specified range.
=COUNTIF(A2:A5,A4)
This, for example, cont values in A2:A5 that matches the values in A4.
Also, you will find the conditional formatting tools in the home tab, if you are using excel 2016.
See the link for more information:
Information you may need
I have I data set on Excel. Starting at column B, it has continuous data from B3 to a variable number that periodically get larger (today it is B114, but tomorrow the data may extend to B116, for example). The data in cell B in continuous and is never deleted. For every row of continuous data in column B, I want to select column B-AG's rows as well. However, the rows after B do NOT have continuous data.
For example: There is continuous data from B3 to B120. I want to select the range B3:AG120.
The code I have written to do this in VBA is not working. It correctly stops at B120 (in this example), however, once it reaches the non-continuous data in columns C-AG, it freaks out and selects rows past 120. I am not positive why this code is not working, any help is much appreciated!
For the record, there are formulas in nearly every cell in the sheet. Only some formula populate the cell with data, however. I want to select every cell regardless of if it is populated with data IF IT IS IN MY RANGE. Otherwise, I do not want to select it. For example, past B120 there are empty cells with formulas in them. I do not want to include those in my range. But if there is an empty cell in D40 (in between B3 and AG120) I do want to include that in the selection.
Dim LR As Long, cell As Range, rng As Range
With Sheets("Sortable(2)")
LR = .Range("B" & Rows.Count).End(xlUp).Row
For Each cell In .Range("B3:B" & LR)
If cell.Value <> "" Then
If rng Is Nothing Then
Set rng = cell
Else
Set rng = Union(rng, cell)
End If
End If
Next cell
rng.Select
End With
Dim lastVal As Range, sht As Worksheet
Set sht = Sheets("Sortable(2)")
Set lastVal = sht.Columns(2).Find("*", sht.Cells(1, 2), xlValues, _
xlPart, xlByColumns, xlPrevious)
Debug.Print lastVal.Address
sht.Range("B2", lastVal).Resize(, 32).Select 'select B:AG
I have already created a VBA script that is about 160 lines long, which produces the report that you see below.
Without using cell references (because the date ranges will change each time I run this) I now need to take the users ID, name, total hours, total break, overtime 1, and overtime 2 and copy this data into sheet 2.
Any suggestions as to how I can structure a VBA script to search row B until a blank is found, when a blank is found, copy the values from column J, K, L, M on that row, and on the row above copy value C - now paste these values on sheet 2. - Continue this process until you find two consecutive blanks or the end of the data...
Even if you can suggest a different way to tackle this problem than the logic I have assumed above it would be greatly appreciated. I can share the whole code if you are interested and show you the data I began with.
Thank you in advance,
J
As discussed, here's my approach. All the details are in the code's comments so make sure you read them.
Sub GetUserNameTotals()
Dim ShTarget As Worksheet: Set ShTarget = ThisWorkbook.Sheets("Sheet1")
Dim ShPaste As Worksheet: Set ShPaste = ThisWorkbook.Sheets("Sheet2")
Dim RngTarget As Range: Set RngTarget = ShTarget.UsedRange
Dim RngTargetVisible As Range, CellRef As Range, ColRef As Range, RngNames As Range
Dim ColIDIndex As Long: ColIDIndex = Application.Match("ID", RngTarget.Rows(1), 0)
Dim LRow As Long: LRow = RngTarget.SpecialCells(xlCellTypeLastCell).Row
'Turn off AutoFilter to avoid errors.
ShTarget.AutoFilterMode = False
'Logic: Apply filter on the UserName column, selecting blanks. We then get two essential ranges.
'RngTargetVisible is the visible range of stats. ColRef is the visible first column of stats.
With RngTarget
.AutoFilter Field:=ColIDIndex, Criteria1:="=", Operator:=xlFilterValues, VisibleDropDown:=True
Set RngTargetVisible = .Range("J2:M" & LRow).SpecialCells(xlCellTypeVisible)
Set ColRef = .Range("J2:J" & LRow).SpecialCells(xlCellTypeVisible)
End With
'Logic: For each cell in the first column of stats, let's get its offset one cell above
'and 7 cells to the left. This method is not necessary. Simply assigning ColRef to Column C's
'visible cells and changing below to CellRef.Offset(-1,0) is alright. I chose this way so it's
'easier to visualize the approach. RngNames is a consolidation of the cells with ranges, which we'll
'copy first before the stats.
For Each CellRef In ColRef
If RngNames Is Nothing Then
Set RngNames = CellRef.Offset(-1, -7)
Else
Set RngNames = Union(RngNames, CellRef.Offset(-1, -7))
End If
Next CellRef
'Copy the names first, then RngTargetVisible, which are the total stats. Copying headers is up
'to you. Of course, modify as necessary.
RngNames.Copy ShPaste.Range("A1")
RngTargetVisible.Copy ShPaste.Range("B1")
End Sub
Screenshots:
Set-up:
Result:
Demo video here:
Using Filters and Visible Cells
Let us know if this helps.
Could someone please help me with some VBA code.
I am trying to copy 2 ranges of cells between workbooks (both workbooks should be created beforehand as i don't want the code to create a new workbook on the fly).
Firstly I need to copy these ranges-
From 'Sheet 3' of booka.xls, Range: Cell H5 to the last row in column H with data
copy this to 'Sheet 1' of bookb.xls, starting in Cell B2 for as many cells down in the B column
Secondly I need to copy these ranges-
From 'Sheet 3' of booka.xls, Range: Cell K5 to the last row in column K with data
copy this to 'Sheet 1' of bookb.xls, starting in Cell D2 for as many cells down in the D column
Here is what I have so far:
Sub CopyDataBetweenBooks()
Dim iRow As Long
Dim wksFr As Worksheet
Dim wksTo As Worksheet
wksFr = "C:\booka.xls"
wksTo = "C:\bookb.xls"
Set wksFrom = Workbooks(wksFr).Worksheets("Sheet 3")
Set wksTo = Workbooks(wksTo).Worksheets("Sheet 1")
With wksFrom
For iRow = 1 To 100
.Range(.Cells(iRow, 8), .Cells(iRow, 9)).Copy wksTo.Cells(iRow, 8)
Next iRow
End With
End Sub
Assuming you have the reference to wksFrom and wksTo, here is what the code should be
wksFrom.Range(wksFrom.Range("H5"), wksFrom.Range("H5").End(xlDown)).Copy wksTo.Range("B2")
wksFrom.Range(wksFrom.Range("K5"), wksFrom.Range("K5").End(xlDown)).Copy wksTo.Range("D2")
Here's an example of how to do one of the columns:
Option Explicit
Sub CopyCells()
Dim wkbkorigin As Workbook
Dim wkbkdestination As Workbook
Dim originsheet As Worksheet
Dim destsheet As Worksheet
Dim lastrow As Integer
Set wkbkorigin = Workbooks.Open("booka.xlsm")
Set wkbkdestination = Workbooks.Open("bookb.xlsm")
Set originsheet = wkbkorigin.Worksheets("Sheet3")
Set destsheet = wkbkdestination.Worksheets("Sheet1")
lastrow = originsheet.Range("H5").End(xlDown).Row
originsheet.Range("H5:H" & lastrow).Copy 'I corrected the ranges, as I had the src
destsheet.Range("B2:B" & (2 + lastrow)).PasteSpecial 'and destination ranges reversed
End Sub
As you have stated in the comments, this code above will not work for ranges with spaces, so substitute in the code below for the lastrow line:
lastrow = originsheet.range("H65536").End(xlUp).Row
Now ideally, you could make this into a subroutine that took in an origin workbook name, worksheet name/number, and range, as well as a destination workbook name, worksheet name/number, and range. Then you wouldn't have to repeat some of the code.
You can use special cells like Jonsca has suggested. However, I usually just loop through the cells. I find it gives me more control over what exactly I am copying. There is a very small effect on performance. However, I feel that in the office place, making sure the data is accurate and complete is the priority. I wrote a response to a question similar to this one that can be found here:
StackOverflow - Copying Cells in VBA for Beginners
There is also a small demonstration by iDevelop on how to use special cells for the same purpose. I think that it will help you. Good luck!
Update
In response to...
good start but it doesn't copy anything after the first blank cell – trunks Jun 9 '11 at 5:08
I just wanted to add that the tutorial in the link above will address the issue brought up in your comment. Instead of using the .End(xlDown) method, loop through the cells until you reach the last row, which you retrieve using .UsedRange.Rows.Count.