So my current code is below - this simply finds the value of "E1" on my source sheet - finds that value on the dest sheet then pastes the data from a set range undereneath the cells with that value.
However I would like to match a column and row for example:
I want to find the value of columns A:A in the source sheet - match this to the correct row in the dest sheet but also match this to the value of "E1" in the source sheet.
Does this make sense - please if you need more let me know - I'm new here.
WkNo = Source.Range("E1").Value
With Source
Set rFndCell = Dest.Range("1:1").Find(WkNo, LookIn:=xlValues)
fcol = rFndCell.Column
Source.Range("B2:C10000").Copy
Dest.Cells(3, fcol).PasteSpecial (xlPasteValues)
Source Sheet
Destination Sheet
Here's a quick example of how to construct the VBA solution. It doesn't use formulas or copy-paste. To copy the values, it's a quick assignment from one cell to another.
Option Explicit
Sub CopyWeeklyValues()
Dim weekNumber As Long
weekNumber = Source.Range("E1").Value
Dim fndCell As Range
Set fndCell = Dest.Range("1:1").Find(weekNumber, LookIn:=xlValues)
If Not fndCell Is Nothing Then
Dim weekColumn As Long
weekColumn = fndCell.Column
'--- now loop over all the rows to copy the data
' to the correct row
With Source
Dim lastRow As Long
lastRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
Dim i As Long
For i = 2 To lastRow
Dim partNumber As String
partNumber = .Cells(i, 1).Value
Dim destPart As Range
Set destPart = Dest.Range("A:A").Find(partNumber, LookIn:=xlValues)
If Not destPart Is Nothing Then
destPart.Cells(1, weekColumn).Value = .Cells(i, 2)
destPart.Cells(1, weekColumn + 1).Value = .Cells(i, 3)
Else
'--- what happens if you can't find the part number?
End If
Next i
End With
Else
'--- couldn't find the week number on the destination sheet
' do something about it?
End If
End Sub
Related
Need some help with my macro. What I need is to loop through a filterable list of IDs in Sheet2 and match them to where the ID is contained in Column 16 on Sheet 1. Then copy over the whole matched row in Sheet1 over to a Sheet3.
Here's what Sheet2 looks like, generally (filtering by things like Status, etc.):
ID
Summary
Created On
Status
1234567
Text
Date
Done
2345678
Text
Date
In Progress
And Sheet1 (*note the ID -> ID2 match):
ID
Summary
Created On
Status
ID2
#######
Text
Date
Done
1234567, #######, #######
#######
Text
Date
In Progress
#######, 2345678
I used this thread here (Code needed to loop through column range, check if value exists and then copy cells) for a process of pairing in the same workbook that does not need to be filtered, and it seems to work just fine. However, my code in this instance is not pairing the amount of rows correctly nor is it pairing with the correct IDs either. I think something may be off with the pairing process with filtering in the mix?
My code so far:
Public Sub PairingBackTEST()
Dim WS As Worksheet
Set WS = Sheets("Sheet1")
'Clears Sheet 3
Sheets("Sheet3").Activate
Sheets("Sheet3").Cells.Clear
' Get the number of used rows for each sheet
Dim RESULTBlocked As Integer, Blockers As Integer
RESULTBlocked = WS.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count
Debug.Print RESULTBlocked
Blockers = Worksheets(1).Cells(1048576, 1).End(xlUp).Row
Debug.Print Blockers
RESULTBlockers = Worksheets(4).Cells(1048576, 1).End(xlUp).Row
'Set date/time format for Created On and Due Date columns
Sheets("Sheet3").Activate
Sheets("Sheet3").Columns("H:H").Select
Selection.NumberFormat = "[$-en-US]m/d/yy h:mm AM/PM;#"
Sheets("Sheet3").Columns("I:I").Select
Selection.NumberFormat
'Pairing
With Worksheets(1)
'Loop through Sheet2
For i = 1 To Blockers
'Loop through Sheet1
For j = 1 To RESULTBlocked
If InStr(1, .Cells(i, 16), WS.Cells(j, 1), vbBinaryCompare) > 0 Then
' If a match is found:
RESULTBlockers = RESULTBlockers + 1
For k = 1 To 17 'How ever many columns there are
Sheets("Sheet3").Cells(RESULTBlockers, k) = .Cells(i, k)
Next
Exit For
Else
End If
Next j
Next i
End With
'Prepare headers on RESULT Blocked
Sheets("Sheet1").Rows(1).Copy
Sheets("Sheet3").Range("A1").PasteSpecial
I'd maybe try an approach like this:
Public Sub PairingBackTEST()
Dim wb As Workbook
Dim wsList As Worksheet, wsCheck As Worksheet, wsResults As Worksheet
Dim lrList As Long, lrCheck As Long, c As Range, cDest As Range, id, m
'use workbook/worksheet variables for clarity, and to avoid repetition...
Set wb = ThisWorkbook
Set wsList = wb.Worksheets("Sheet2")
Set wsCheck = wb.Worksheets("Sheet1")
Set wsResults = wb.Worksheets("Sheet3")
'no need for activate/select here
With wsResults
.Cells.Clear
.Columns("H:H").NumberFormat = "[$-en-US]m/d/yy h:mm AM/PM;#"
'.Columns("I:I").NumberFormat = ??? this is missing in your posted code
wsCheck.Rows(1).Copy .Range("A1") 'copy headers
End With
Set cDest = wsResults.Range("A2") 'first destination row on result sheet
For Each c In wsList.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells
id = c.Value
'you can use match in place of looping as long as there's only one row to find
m = Application.Match("*" & id & "*", wsCheck.Columns(16), 0)
If Not IsError(m) Then
If m > 1 Then 'avoid matching on header...
cDest.Resize(1, 17).Value = wsCheck.Cells(m, 1).Resize(1, 17).Value
Set cDest = cDest.Offset(1, 0) 'next row on results sheet
End If
End If
Next c
End Sub
I've been struggling with this all day and I'm sure there's a really simple answer that I'm just not finding so hoping someone can point me in the right direction!
What I want to achieve is:
see if a value (R.BName) from sheet1 (wsResults) can be found in column c of sheet2 (wsSchedule);
if found, paste a value from sheet1 (that I've already copied) into
the next empty cell of that row;
if not found, insert a value into a specific cell in sheet1
The 2 issues I'm having are that:
If there is a match - the paste location is the last cell in row1 - yes, I know that this be because my code has (1,columns.count) but I don't know how to get it to select the cell of the match!
"broker name not found on review schedule" is being added to wsResults even if a match was on wsSchedule
Here is my defective code:
'copy result from wsresults
wsResults.range("R.Result").Copy
'find broker & add result to review schedule sheet
Dim wsSchedule As Worksheet
Dim rSearch As range
Dim c As range
Set wsSchedule = Worksheets("Review Schedule")
Set rSearch = wsSchedule.range("C5:C400")
For Each c In rSearch
If c.Value = wsResults.range("R.BName").Value Then
wsSchedule.Cells(1, Columns.count).End(xlToLeft).Offset(0, 1).PasteSpecial xlPasteValues
Else
With wsResults
.range("AP2:AP2").Value = "Broker name not found on review schedule"
End With
End If
Next c
Any assistance that can be offered would be greatly appreciated!
I believe this is what you had in mind. Please try it.
Sub Test()
' 009
Dim wsSchedule As Worksheet
Dim wsResults As Worksheet
Dim searchCrit As Variant
Dim lastR As Long
Dim R As Long
Set wsSchedule = Worksheets("Review Schedule")
Set wsResults = Worksheets("Results")
' try to access sheet values as little as possible: it's slow
' here, once is enough. No need to do it on every loop
searchCrit = wsResults.Range("R.BName").Value
With wsSchedule
lastR = .Cells(.Rows.Count, "C").End(xlUp).Row
For R = 5 To lastR
If .Cells(R, "c").Value = searchCrit Then
.Cells(R, Columns.Count).End(xlToLeft).Offset(0, 1) = wsResults.Range("R.Result")
Exit For
End If
Next R
End With
' R will be <=lastR if a match was found
If R > lastR Then
wsResults.Cells(2, "AP").Value = "Broker name not found on review schedule"
End If
End Sub
However, #SJR is right: using Find in place of the loop would be more efficient.
I have and excel workbook with multiple sheets and I need a range from each one to be copied into one "Main" sheet (one under another) if a condition is met.
Each sheet is different and the number of rows and cells may vary.
In all of the sheets (except the main sheet which is blank) cell B1 is a check cell that contains "yes" or is blank.
If cell B1 ="yes" the macro must migrate the range (from row 2 to the lat filled in row) into the main sheet.
The selected ranges must be copied one under another in the main sheet (so that it's like a list)
I am still a beginner in VBA and if anyone could help me a little with the code I would very much appreciate it :).
I tried to build in the code using "For Each - Next" but perhaps it would be better to make it with a Loop cicle or something else.
Sub Migrate_Sheets()
Dim wksh As Worksheet, DB_range As Range, end_row As Long, con_cell As Variant
con_cell = Range("B1")
'end_row = Range("1048576" & Rows.Count).End(xlUp).Rows
For Each wksh In Worksheets
If con_cell = "Yes" Then
Set DB_range = Range("2" & Rows.Count).End(xlDown).Rows
DB_range.Copy
wksh("Main").Activate
'row_end = Range("2" & Rows.Count).End(xlUp).Rows
Range("A1").End(xlDown).Offset(1, 0).Paste
End If
Next wksh
End Sub
There are quite a few issues here - I suggest you do some reading on VBA basics - syntax, objects, methods etc.
I've assumed you are only copying column B.
Sub Migrate_Sheets()
Dim wksh As Worksheet, DB_range As Range
For Each wksh In Worksheets
If wksh.Name <> "Main" Then 'want to exclude this sheet from the check
If wksh.Range("B1").Value = "Yes" Then 'refer to the worksheet in the loop
Set DB_range = wksh.Range("B2", wksh.Range("B" & Rows.Count).End(xlUp)) 'you need Set when assigning object variables
DB_range.Copy Worksheets("Main").Range("A" & Rows.Count).End(xlUp).Offset(1, 0) 'better to work up from the bottom and then go down 1
End If
End If
Next wksh
End Sub
See if this helps, though you might need to make some minor changes to match your data sets..
Sub Migrate_Sheets()
Dim wksh As Worksheet, mainWS As Worksheet
Dim DB_range As Range, con_cell As String
Dim lRow As Long, lCol As Long, lRowMain As Long
Set mainWS = ThisWorkbook.Worksheets("Main")
For Each wksh In Worksheets
con_cell = wksh.Range("B1").Value 'You want to use this variable within the loop
If wksh.Name <> "Main" And con_cell = "Yes" Then
lRowMain = lastRC(mainWS, "row", 1) + 1 'Add 1 to the last value to get first empty row
lRow = lastRC(wksh, "row", 1) 'Get the last row at column 1 - adjust to a different column if no values in column 1
lCol = lastRC(wksh, "col", 2) 'Get the last column at row 2 - adjust to a different row if no values in row 2
With mainWS
.Range(.Cells(lRowMain, 1), .Cells(lRowMain + lRow - 1, lCol)).Value = wksh.Range(wksh.Cells(2, 1), wksh.Cells(lRow, lCol)).Value
End With
End If
Next wksh
End Sub
Function lastRC(sht As Worksheet, RC As String, Optional RCpos As Long = 1) As Long
If RC = "row" Then
lastRC = sht.Cells(sht.Rows.Count, RCpos).End(xlUp).row
ElseIf RC = "col" Then
lastRC = sht.Cells(RCpos, sht.Columns.Count).End(xlToLeft).Column
Else
lastRC = 0
End If
End Function
So I am extremely new to VBA but have to finish a project that requires sorting some data. I have two sheets. One sheet( called 'values') has a single column of values that I need to test if a value matches at least one of the 5 columns of a record (row) in another very large sheet ('sheet1'), and copy the whole record (row) to a second spreadsheet ('sheet2).
This is my pseudo code:
for each row in sheet1 where sheet1.row = A1:Q1231231
for each value in values where values.value = b1:b300
for each col (e1:j1) where sheet1.col = E-rownum : J-rownum
if value == col-value
copy row to sheet2
break, esc value
Next row
And this is what i have so far, but i'm a little stuck on whether im referencing everything correctly. How do i just obtain columns E:J for each row when I need to match the values against those cells only? How do I copy the entire row if there is a match, and to immediately break and move on to the next record?
Private Sub CommandButton1_Click()
Dim sheetrow As Range
Dim Values As Range
Dim cells As Range
Set Sheet1 = Worksheets("Sheet1")
Set Values = Worksheets("values").Rows("B2:B330")
Set Sheet2 = Worksheets("Sheet2")
For Each sheetrow In Sheet1.Rows
For Each value In Values
For Each cell In sheetrow.cells // only need cell cols E:J
//if value == cell
// copy row to sheet2
//break (no need to check the rest of the row if match)
Next
Next
Next
End Sub
Just to inform, this is not for a VBA assignment. This is just a very large amount of data and a script would work better than trying to manually go through it. Thank you so much!
Your pseudo-code looks good, I did remove the 3rd loop though, albeit you could certainly loop through the columns.
Is this what you are looking for?
Option Explicit
Sub Test()
Dim i As Long
Dim j As Long
Dim rngValues As Range
Dim rng As Range
Dim Sheet1 As Worksheet
Dim Sheet2 As Worksheet
Application.ScreenUpdating = False 'Turns of Screenupdating to let the code run faster
Set Sheet1 = ThisWorkbook.Sheets("Sheet1")
Set Sheet2 = ThisWorkbook.Sheets("Sheet2")
Set rngValues = ThisWorkbook.Sheets("Values").Range("B2:B330")
j = 1 'counter to count up the rows on the destination sheet
For i = 1 To Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row 'determines the last row on Sheet1
For Each rng In rngValues
'default return value of range is the value in it, so there would be no need to use range.value
' _ continues the code in the next line for readability
If Sheet1.Cells(i, 5).Value = rng.Value or Sheet1.Cells(i, 6).Value = rng.Value Or Sheet1.Cells(i, 7).Value = rng.Value or _
Sheet1.Cells(i, 8).Value = rng.Value or Sheet1.Cells(i, 9).Value = rng.Value Or Sheet1.Cells(i, 10).Value = rng.Value Then
'This copies the entire row an parses it to destination
Sheet1.Cells(i, 1).EntireRow.Copy Destination:=Sheet2.Cells(j, 1)
j = j + 1
End If
Next
Next
Application.ScreenUpdating = True
End Sub
I'm not sure if I understood your question correctly though.
We have two worksheets.
Source worksheet is "profes"
Target worksheet is "primaria"
The data common to both worksheets is the name column.
ie: David Smith Weston appears in both worksheets.
We need to "lookup" each students name and paste values from "profes" to "primaria". I have most of the code working already BUT I don't know how to add the "lookup" part. As you can see it's wrong.
Sub Button1_Click()
Set Source = ActiveWorkbook.Worksheets("profes")
Set Target = ActiveWorkbook.Worksheets("primaria")
j = 1 ' Start copying to row 1 in target sheet
For Each c In Source.Range("N5:R1000") ' Do 100 rows
**If Source.Cells(j, "C").Value = Target.Cells(j, "A").Value** Then
Target.Cells(j, "N").Value = Source.Cells(j, "D").Value
j = j + 1
End If
Next c
End Sub
When comparing 2 ranges between 2 worksheets, you have 1 For loop, and replace the second loop with the Match function.
Once you loop over your "profes" sheet's range, and per cell you check if that value is found within the second range in "primaria" sheet, I used LookupRng, as you can see in the code below - you will need to adjust the range cording to your needs.
Code
Option Explicit
Sub Button1_Click()
Dim Source As Worksheet, Target As Worksheet
Dim MatchRow As Variant
Dim j As Long
Dim C As Range, LookupRng As Range
Set Source = ActiveWorkbook.Worksheets("profes")
Set Target = ActiveWorkbook.Worksheets("primaria")
' set up the Lookup range in "primaria" sheet , this is just an example, modify according to your needs
Set LookupRng = Target.Range("A2:A100")
For Each C In Source.Range("N5:R1000") ' Do 100 rows
If Not IsError(Application.Match(C.Value, LookupRng, 0)) Then ' Match was successfull
MatchRow = Application.Match(C.Value, LookupRng, 0) ' get the row number from "primaria" sheet where match was found
Target.Cells(C.Row, "N").Value = Source.Cells(MatchRow, "D").Value
End If
Next C
End Sub
Use the worksheet's MATCH function to locate names from the source column C in the target's column A.
Your supplied code is hard to decipher but perhaps this is closer to what you want to accomplish.
Sub Button1_Click()
dim j as long, r as variant
dim source as worksheet, target as worksheet
Set Source = ActiveWorkbook.Worksheets("profes")
Set Target = ActiveWorkbook.Worksheets("primaria")
with source
for j = 5 to .cells(.rows.count, "C").end(xlup).row
r=application.match(.cells(j, "C").value2, target.columns("A"), 0)
if not iserror(r) then
target(r, "D").resize(1, 5) = .cells(j, "N").resize(1, 5).value
end if
next j
end with
End Sub