I would need a code that would allow me to copy and paste the information based on the matching IDs. The problem is that the number of rows that both my sheets has is more than 200000 rows with IDs on each rows. Some of the IDs are repeated in sheet 2. I only manage to create a code but it seems to be running and then it crash. Sheet 2 consist of all the information while Sheet 1 is where the information will be pasted when the IDs from both sheets matched.
This is the code that i have so far. I really hope anyone could help me with this as this code seems to keep running and crash and my VBA skills is very limited,
Sub AAA()
Dim tracker As Worksheet
Dim master As Worksheet
Dim cell As Range
Dim cellFound As Range
Dim OutPut As Integer
Set tracker = Workbooks("test.xlsm").Sheets("Sheet1")
Set master = Workbooks("test.xlsm").Sheets("Sheet2")
For Each cell In master.Range("A2:A100000")
' Try to find this value in the source sheet
Set cellFound = tracker.Range("A5:A100000").Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not cellFound Is Nothing Then
' A matching value was found
' So copy the cell 2 columns across to the cell adjacent to matching value
' Do a "normal" copy & paste
cellFound.Offset(ColumnOffset:=2).Value2 = cell.Offset(ColumnOffset:=2).Value2
' Or do a copy & paste special values
'cell.Offset(ColumnOffset:=2).Copy
'cellFound.Offset(ColumnOffset:=1).PasteSpecial xlPasteValues
Else
' The value in this cell does not exist in the source
' Should anything be done?
End If
Next
OutPut = MsgBox("Update over!", vbOKOnly, "Update Status")
End Sub
I had the same problem and was able to resolve it by deallocating the variable cellFound before re-assigning it. So, I suggest that you add:
Set cellFound = Nothing
right after the End If.
Hope that helps.
Related
I am trying to create an Excel Macro to copy formulas along a used range and then copy the form and paste values.
I was thinking that I house the formulas that need to be copied in a template file in row 1. Users can then input data into as many rows as they please, and the macro will copy down all formulas to all used rows, and then copy/paste values of the entire sheet.
Can anyone help with writing this? I have attempted to write it myself but haven't been able to get very far.
Thanks!
EDIT- - I have gotten the copy part down I believe. Now I just need to copy/paste values on the majority of the sheet, starting from row 4 down.
Sub Forecast()
Application.ScreenUpdating = False
' Get the last row on the sheet - store as variable
Dim LastRow As Integer
LastRow = Range("A1").End(xlDown).Row
' Copy cells K3:AY3 to cells K4:AY[LastRow]
Range(Cells(3, 11), Cells(3, 51)).AutoFill _
Destination:=Range(Cells(3, 11), Cells(LastRow, 51))
Application.ScreenUpdating = True
End Sub
To copy the values for a variable number of rows between two locations do the following:
Dim r_src as Range, r_dst as Range
' Set to the top cell of the source
Set r_src = Sheet1.Range("A2")
Dim n as Long
' Count the non-empty cells
n = Sheet1.Range(r_src, r_src.End(xlDown)).Rows.Count
' Set the range to include all 'n' cells using the `.Resize()` command
Set r_src = r_src.Resize(n,1)
' Set 'n' values in the destination sheet also
Set r_dst = Sheet2.Range("A2").Resize(n,1)
'This actually copies the range as values in one swoop
r_dst.Value = r_src.Value
To copy the formulas you can use
r_dst.FormulaR1C1 = r_src.FormulaR1C1
I have two sheets, One labeled "Assignments" and another "Backup". What I am trying to achieve is to copy the information on "Assignments" to "Backup" to allow for new data to be entered.
However, once copied to "Backup" and new information is supplied to "Assignments" I am looking to loop through each item in column A on "Backup" and copy the adjacent cell (Column B) to the corresponding cell value found on "Assignments".
So far this is the code that I have but am not returning any viable results:
Option Explicit
Sub Match()
Dim RNG As Range
Dim RI As Range
Dim WS As Worksheet
Dim f As Range
Set WS = ActiveWorkbook.Sheets("Assignments")
Set RNG = Sheets("Assignments Backup").Range("A2:A400")
For Each RI In RNG
With WS
'RI.Select
Set f = .Columns(1).SpecialCells(xlCellTypeConstants).Find(What:=Cells(Target.Row, 1), LookIn:=xlFormulas, LookAt:=xlWhole) '<--| try finding "Emp #" from Assignments sheet changed cell row column B in referenced sheet ("i.e. "Checklist") column "A" cells not blank cells
If f Is Nothing Then '<--| if "Emp #" match not found
'MsgBox "I couldn't find " & Cells(Target.Row, 1).Value & " in worksheet 'Checklist'"
Else ' <-- if "Emp #" match found
.Range("F:F").Rows(f.Row).Value = Range("F:F").Rows(Target.Row).Value '<--| paste "Assigmnents" sheet changed cell row columns "AA:AF" content in corresponiding columns of referenced sheet ("i.e. "Checklist") row where "Emp #" match was found
End If
End With
Next
End Sub
I apologize for the delay, I have uploaded an example file to my google drive. [https://drive.google.com/open?id=0B0jgh8FwPVvkWk40TEczYVFjX0k][1]
As you will notice column B contains different data between both sheets. However, as mentioned, I would like the information from column B in backup to replace what is in column B on assignments according to the data in Column A in each. I have also included the code below.
EDIT
I updated the code above as I realized that I had not posted the correct code that I was originally attempting to work with.
My dear friend, your "code" is a mess - and that is a very polite way of putting it. I spent half an hour just to clean it up. But that is only to make the problems visible.
Sub MatchEntries()
Dim WsA As Worksheet ' Worksheet "Assignments"
Dim WsB As Worksheet ' Worksheet "Assignments Backup"
Dim WsC As Worksheet ' Worksheet "Checklist"
Dim Cell As Range ' Cells in RngA
Dim Fnd As Range ' Find match
Dim R As Long, C As Long ' row and column
With ActiveWorkbook
Set WsA = .Worksheets("Assignments")
Set WsB = .Worksheets("Assignments Backup")
Set WsC = .Worksheets("Checklist")
End With
For Each Cell In WsB.Range("A2:A400")
Set Fnd = WsC.Columns(1).Find(What:=Cell.Value, LookIn:=xlFormulas, LookAt:=xlWhole)
' <--| try finding "Emp #" from Assignments sheet changed cell row column B
' in referenced sheet ("i.e. "Checklist") column "A" cells not blank cells
If Fnd Is Nothing Then '<--| if "Emp #" match not found
MsgBox "I couldn't find " & Cell.Value & " in worksheet 'Checklist'"
Else ' <-- if "Emp #" match found
R = Fnd.Row
For C = 27 To 32 ' columns AA to AF
WsA.Cells(R, C).Value = WsC.Cells(R, C).Value
Next C
' .Range("Fnd:Fnd").Rows(Fnd.Row).Value = Range("Fnd:Fnd").Rows(Target.Row).Value
' <--| paste "Assigmnents" sheet changed cell row columns "AA:AF" content
' in corresponiding columns of referenced sheet ("i.e. "Checklist") row
' where "Emp #" match was found
End If
Next Cell
End Sub
To start with, don't call your sub "Match". Match is a worksheetfunction, and there is no telling what Excel will do when it meets "your" choice of name.
Second, you seem to have 3 sheets. So, I declared 3 sheets. From your post it isn't possible to tell if that assumption is correct or not, but you can see the logic, I believe. Also, once you have so many variables you will need to be a little imaginative with the names. You can't call all your 8 sons John1, John2, John3, etc. By the same token I named one of your ranges Cell and another Fnd. You will be able to tell the difference between them by their names.
Now you can see that you are looking through all the cells in column A of the Backup sheet (WsB). That doesn't look like a very good idea because there are likely to be a lot of blank cells. Matches will be found for them. I took the liberty to presume that you are looking in the Checklist sheet. If that is wrong, it is now easy to change the sheet or the column.
If a match is found you want to do something. I couldn't make out what it is you want to do, but I wrote code there which should be easy for you to understand and modify so that it does what you actually want.
I am having difficulty looping through each column before looping through the next row. The number of columns is fixed (A:K) with an unknown number of rows. The goal is to find highlighted cells (no distinct color.. and I figured the best way to do this is to code "If Not No Fill") and copy that whole row to another workbook. This is what I have so far and I am stuck:
Option Explicit
Sub Approval_Flow()
Dim AppFlowWkb As Workbook, ConfigWkb As Workbook
Dim AppFlowWkst As Worksheet, ConfigWkst As Worksheet
Dim header As Range, headerend As Range
Dim row As Long, column As Long
Set AppFlowWkb = Workbooks.Open("C:\Users\clara\Documents\Templates and Scripts\Approval Flow Change Log.xlsx")
Set ConfigWkb = ThisWorkbook
Set AppFlowWkst = AppFlowWkb.Sheets("Editor")
Set ConfigWkst = ConfigWkb.Worksheets("Approval Flows")
With ConfigWkb
Set header = Range("A7").Cells
If Not header Is Nothing Then
Set headerend = header.End(xlDown).row
For row = 7 To headerend
For j = 1 To 11
'if cell is filled (If Not No Fill), copy that whole row to another workbook
End With
End Sub
I am getting an error with the Set headerend line, but I am trying to select the last row to use it in my for loop. I appreciate any help and guidance. Thanks in advance!
You should be able to adapt this to suit your workbooks, see the comments for details
Dim aCell as Range
' Use UsedRange to get the variable number of rows,
' cycle through all the cells in that range
For Each aCell In ActiveSheet.Range("A1:K" & ActiveSheet.UsedRange.Rows.Count)
' Test if fill colour is white (none)
If Not aCell.Interior.Color = RGB(255,255,255) Then
' Insert new row in target sheet (could find last row instead)
ActiveWorkbook.Sheets("ThisOtherSheet").Range("A1").EntireRow.Insert
' Paste entire row into target sheet
aCell.EntireRow.Copy Destination:=ActiveWorkbook.Sheets("ThisOtherSheet").Range("A1")
End If
Next aCell
Alternatively to find the last row, if you know the range is continuous (no blanks) then you can use End(xlDown) like you had done, and like below
For Each aCell In ActiveSheet.Range("A1:K" & ActiveSheet.Range("K1").End(xlDown))
I'd guess you don't want to copy the same row multiple times if you've already copied it. You could do this by keeping an array or string with previously copied row numbers and checking before copying again, or use Excel's unique functions to strip the list down after copying.
Hope this helps.
Aside:
You're using a With block but not taking advantage of it, you need to put a dot . before your Range objects to specify that they're in your With sheet. Like so
Dim myRange as Range
With ActiveSheet
Set myRange = .Range("A1:C10")
End With
You're mixing the types.
It looks like you just want to use the Row that the Header data ends on.
Take out the .Row there, since you're setting headerend to be a cell address, not a specific value. Then change For row = 7 To headerend to For row = 7 To headerend.Row
Or, change Dim Headerend as Range to ...as Long and just do headerEnd = header.End(xlDown).Row (don't use Set)
Ok Hi everybody,
I've been looking into this and trying to figure it out for a couple days now. I've found things close but nothing matches what I need.
I have 13 departments here and each department has a sheet with issues that need to be resolved. What I need is when each of those departments updates their excel sheet with an issue it updates on the master list (which is in the same workbook). Since people are constantly deleting and adding the formula would need to stay.
Would it be easier to have them enter the data on the master sheet and have that go into the individual files? If so how would I even do that? Thanks in advance. I'm trying to see if an advance filter or something would work but can't get it just right.
You will need to adjust the names in my code but if you paste this code in each of your department sheets (not the master list) you should get your desired result:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
Dim xlws As Excel.Worksheet
Set xlws = ActiveSheet
For i = 1 To 13
If IsEmpty(xlws.Cells(2, i).Value) = True Then
Exit Sub
End If
Next
Dim xlwsMaster As Excel.Worksheet
Set xlwsMaster = ActiveWorkbook.Worksheets("master list")
i = 1
Do While IsEmpty(xlwsMaster.Range("A" & i).Value) = False
i = i + 1
Loop
xlws.Range("A2:M2").Copy
xlwsMaster.Range("A" & i).PasteSpecial xlPasteAll
xlws.Range("A2:M2").Clear
End Sub
every time there is a change on one of those sheets it will check to see if all the values of a through m are filled if they are it copies a2:m2 and pastes it at the first empty row on the master list and then clears a2:m2 on the sheet in question
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.