I have done my best to read every thread imaginable to rewrite my overall code to get this to work.
Situation: I have data in sheet2 (Scores) and data in sheet3 (Comments). In each sheet, column A has a ticket number. The Scores sheet includes every possible ticket number; the Comments sheets only includes a subset of that total (approx 50%). The Scores sheet includes 4 populated columns while the Comments sheet has 2. I need the lookup to match the common existing rows (ticket numbers), and then take the value in Comments column B (2) and paste it in Column E (5) of sheet1, which is the CSAT Summary sheet, and has the contents of Col A-D from the Scores sheet.
Below is the current code. If I remove the VLookup and just put a variable (such as "A"), it does paste A in the correct column, albeit on every single line...
scores.UsedRange.Columns.Copy
csatSum.Range("A1").Insert
csatSum.Activate
Set rng = csatSum.Range("A2:A" & lastRow)
rngLastRow = Comments.Range("B2:B" & lastRow)
For i = 2 To lastRow
On Error Resume Next
csatSum.Cells(i, 5) = WorksheetFunction.VLookup(rng, Comments.Range(rngLastRow), 2, False)
On Error GoTo 0
Next i
Not sure what I am missing. Obviously it is something in the VLookup itself. But I am at a loss.
I think it should be:
scores.UsedRange.Columns.Copy
csatSum.Range("A1").Insert
'csatSum.Activate
'Set rng = csatSum.Range("A2:A" & lastRow)
Set rngLastRow = Comments.Range("A2:B" & lastRow)
For i = 2 To lastRow
On Error Resume Next
csatSum.Cells(i, 5) = WorksheetFunction.VLookup(csatSum.Cells(i, 1), rngLastRow, 2, False)
On Error GoTo 0
Next i
Related
I have two sheets in my workbook.
*EDIT: I figured the reason why the record didnt start at B8. I need to have the header.
Master Sheet
has header range of B7:Y7, records start at B8
Update Dups Sheet
duplicate data from Master sheet will be copied and pasted here.
has the same header range as Master Sheet, and records start at B8
I found the code here, and edited it to suits my data, however, instead of only copying the duplicate data, it copies all of the data. and delete only one instance of duplicate data. (Example: 4 duplicates, only delete 1). the data order is also inverted.
Sub tryagain()
Dim Rng As Range, i As Long
Application.ScreenUpdating = False
Set Rng = Range("B3:B" & Range("B" & Rows.Count).End(xlUp).Row)
For i = Rng.Rows.Count To 1 Step -1
If Application.WorksheetFunction.CountIf(Rng, Cells(i, "B")) > 1 Then
lr = Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Row + 1
Rows(i).EntireRow.Copy Destination:=Sheets("Sheet2").Range("A" & lr)
'Rows(i).EntireRow.Delete
End If
Next i
Application.ScreenUpdating = True
End Sub
The records also didn't start at B8 like intended. I've tried so many ways, and it seems like a dead end for me. Any helps from you are much appreciated.
Try to do one step at a time:
Declare 2 ranges (A and B)
Copy your table from first sheet into the second sheet
Set data from sheet 1 to range A, data from sheet 2 to range B
Remove all duplicates from A
Remove all non duplicates from B
Sort ranges
At the moment I’m only able to copy&paste stuff from one row.
I use the code below:
Dim lastRow As Long
With Sheets("Tab1")
If Application.WorksheetFunction.CountA(.Columns(3)) <> 0 Then
lastRow = .Cells(Rows.Count, "C").End(xlUp).Row + 1
Else
lastRow = 1
End If
Sheets("Tabelle2").Range("B85:S85").copy
.Range("C" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
My problem is that I need to copy and paste lists. Can someone show me how to use this code to copy&paste lists?
I wanted to copy more rows, like (A25:S25, A27:S27, A30:S30)
It should copy always the same rows.
There are two reasons for your code copying just one row:
The code selects just one row to copy
Sheets("Tabelle2").Range("B85:S85").Copy
The select just on row to Paste
.Range("C" & lastRow).PasteSpecial Paste:=xlPasteValues …
As it’s not clear if you want to copy several rows despite selecting just one or to copy that one row to several rows I’ll cover both options in order to give you an idea of what to do in both cases:
Setting the range to be copied
a. To copy just range B85:S85 one row only then what you are doing is correct
Wbk.Sheets("Tabelle2").Range("B85:S85")
b. To copy X rows down from row 85 (including row 85)
Wbk.Sheets("Tabelle2").Range("B85:S85").Resize(X)
c. To copy Y rows up from row 85 (including row 85)
Wbk.Sheets("Tabelle2").Range("B85:S85").Offset(1-Y, 0).Resize(Y)
d. To copy the range bounded by any combination of blank rows and blank columns in which "B85:S85" is included (see Range.CurrentRegion Property (Excel))
Wbk.Sheets("Tabelle2").Range("B85:S85").CurrentRegion
Note that this will include also any rows above and below row 85 if they have at least one cell not blank that causes the "current region" to extend upwards or downwards and it will also include any columns to the left of columns B or to the right of column S if they have at least one cell not blank that causes the "current region" to extend sideways
This procedure demonstrates the options explained above:
Sub Range_Set()
Dim rSrc As Range
With ThisWorkbook.Sheets("Tabelle2")
'If want to copy just this row 85
Application.Goto .Cells(1), 1
Set rSrc = .Range("B85:S85")
rSrc.Select: Stop
'If want to copy 5 rows down from row 85 (including row 85)
Application.Goto .Cells(1), 1
Set rSrc = .Range("B85:S85").Resize(5)
rSrc.Select: Stop
'If want to copy 5 rows up from row 85 (including row 85)
Application.Goto .Cells(1), 1
Set rSrc = .Range("B85:S85").Offset(-4, 0).Resize(5)
rSrc.Select: Stop
'If want to copy then range bounded by any combination of blank rows and blank columns in which "B85:S85" is included
'This will include also any rows above and below row 85 if they have at least one cell not blank that causes the "current region" to extend upwards or downwards
'Also will include also any columns to the left of columns B or to the right of column S if they have at least one cell not blank that causes the "current region" to extend sideways
Application.Goto .Cells(1), 1
Set rSrc = .Range("B85:S85").CurrentRegion
rSrc.Select: Stop
End With
End Sub
Setting the range where the copy takes place
To copy the source range as it is, then just need to select the first cell of your target range and the paste.special will cover paste the target to all cells required as per the size all target cell. However is you want to copy range B85:S85’ to several cell then you need to select the target rows. For example if we want to copyB85:S85’ over five rows starting at C5 then we need to set the target range as
.Range("C12").Resize(5).PasteSpecial Paste:=xlPasteValues
As we are going to copy only the values of the source, I suggest to use the Range.Value property of the Range object instead of the Copy…Paste method. One advantage of using this property is to avoid the use of the Clipboard.
Try this code (select\adjust the options as per your requirements)
Sub Range_Value()
Dim Wbk As Workbook
Dim lastRow As Long
Dim rSrc As Range
Rem Declare Objects
Set Wbk = ThisWorkbook 'use this if procedure is resident in the wbk with the tables
'Set Wbk = Workbooks(WbkName) 'use this if procedure is not resident in the wbk with the tables - update wbk name
With Wbk.Sheets("Tab1")
lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
Rem Set Copy Range
'since we are going to paste only values then we can save us from using the clippboard
'Sheets("Tabelle2").Range("B85:S85").Copy
'instaed create a range to replace the values of the target range with the values of this range
'Uncomment\Update the option needed according to you requirements
'for this test I'm using option b
'a. To copy just row 85
'Set rSrc = Wbk.Sheets("Tabelle2").Range("B85:S85")
'b. To copy X rows down from row 85 (including row 85) X=5
Set rSrc = Wbk.Sheets("Tabelle2").Range("B85:S85").Resize(5)
'c. To copy 5 rows up from row 85 (including row 85) Y=5
'Set rSrc = Wbk.Sheets("Tabelle2").Range("B85:S85").Offset(-4, 0).Resize(5)
'd. To copy the range bounded by any combination of blank rows and blank columns in which "B85:S85" is included
'This will include also any rows above and below row 85 if they have at least one cell not blank that causes the "current region" to extend upwards or downwards
'Also will include also any columns to the left of columns B or to the right of column S if they have at least one cell not blank that causes the "current region" to extend sideways
'Set rSrc = Wbk.Sheets("Tabelle2").Range("B85:S85").CurrentRegion
' As mentioned before we won't use the clipboard
'instead we replace the values with the values of the target range created earlier
'however we need to extend the range to the same size of the source range
.Range("C" & lastRow + 1).Resize(rSrc.Rows.Count, rSrc.Columns.Count).Value = rSrc.Value2
End With
End Sub
Hope this is clear enough and helps you to make progress with you coding, nevertheless let me know of any questions you might have.
I'm not quite sure what you're looking for - but here' how to loop:
Sub test()
For i = 25 to 30
Range(Cells(i,1),Cells(i,19)).Copy
Range(Cells(i,20),Cells(i,39)).PasteSpecial xlPasteValues
Next i
End Sub
That copies A25:S25 and pastes to T25:AM25...Then A26:S26, pastes T26:AM26, etc. until row 31.
Well now that the requirements are disclosed, we have the opportunity to apply another method. Bear in mind that the fact that the source range contains multiple areas may give us the idea of series of repetitive "copy paste values" which makes the undesirable use of the clipboard, or a repetitive Range Values.
This time instead of setting the source range as an object (which still can be done) we'll use an Array variable to grab the values of the multi-areas range
to later enter them in the target range as a unified and continuous range in one step.
This procedure sets an array with the values of the source range areas and then sets the values of the array to the target range using the Range.Value property.
Sub Range_MultiAreas_CopyValue()
Const kRowIni As Long = 25
Dim Wbk As Workbook
Dim aRngSrc() As Variant
Dim lRowLst As Long, l As Long, b As Byte
Rem Declare Objects
Set Wbk = ThisWorkbook
Rem Set Array with rows to copy as value
With Wbk.Sheets("Tabelle2")
l = kRowIni
For b = 1 To 30
If .Range("V" & l).Value2 = 0 Then
Rem Resize Array
On Error Resume Next
ReDim Preserve aRngSrc(1 + UBound(aRngSrc))
If Err.Number <> 0 Then ReDim Preserve aRngSrc(1)
On Error GoTo 0
Rem Set Row Values In Array
aRngSrc(UBound(aRngSrc)) = .Cells(l, 2).Resize(, 16).Value2
Rem Increase Row Pointer
l = l + 2
End If: Next: End With
Rem Reset Arrays Structure
With WorksheetFunction
aRngSrc = .Transpose(.Transpose(aRngSrc))
End With
Rem Let Array Values in Target Range
With Wbk.Sheets("Tab1")
lRowLst = .Cells(.Rows.Count, 1).End(xlUp).Row
lRowLst = IIf(.Cells(1, 1) = Empty, 1, lRowLst + 1)
.Cells(lRowLst, 1).Resize(UBound(aRngSrc, 1), UBound(aRngSrc, 2)).Value = aRngSrc
End With
End Sub
Once again let me know of any question you might have about the resources used.
As it is not possible to Copy more than one row at once when gaps are between as siddharth rout said we tried to bypass the problem with looping through every signle row which should be copiedand added an if query.
This code is working and i am using "him" now
j = 0
For i = 1 To 30
With Sheets("Arbeiter-Tage")
If Application.WorksheetFunction.CountA(.Columns(1)) <> 0 Then
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
Else
lastRow = 1
End If
Sheets("Vorlage").Activate
If ActiveSheet.Range("V" & 25 + j).Value = 0 Then
ActiveSheet.Range("B" & 25 + j & ":" & "Q" & 25 + j).Copy
.Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End If
End With
j = j + 2
I have a list of query words that I am submitting to a database (Column A) to generate a list of coded matches (Columns F-H). Column F is the original search word (so there is an exact match somewhere in Column A), Column G contains the match, and Column H contains the code for the match. What I need to do is take the query word in Column F and find its partner in Column A. Then I need to take the corresponding match and its code and paste it next to the original search term in Column A (in Columns B&C).
My problem here is getting the information pasted in the correct cell since the copy to and paste from locations change every time -- The list of coded matches in Columns F-H does NOT contain all of the terms in Column A.
I've been searching the internet and I can't seem to figure out what exactly I need to change to allow the paste function to work.
I have attached an image of a simplified version of my spreadsheet and a annotated version of the code I have been working with.
Sub FindMatch()
LastRow = Cells(Rows.Count, 6).End(xlUp).Row
For i = 1 To LastRow
FindMe = Cells(i, 6).Value
Set FoundinList = Cells.Find(What:=FindMe, After:=ActiveCell, LookAt:=xlWhole)
If Not FoundinList Is Nothing Then
FoundinList.Select
ActiveCell.Offset(0, 1).Select
'At this point the cell I want the information pasted into is selected. Yay!
'Example: I am trying to find "abnormal digits" (F1) in Column A and paste
'G1:H1 into the appropriate cells in Columns B & C (In this case B15:C15)
'At this point in the code my cursor is on cell B15 - which is where I need it.
Range(Cells(i, 7), Cells(i, 8)).Copy
'This selects the appropriate range (G1:H1 in my example).
ActiveCell.Paste
'This is the problem string. I've tried naming the "ActiveCell" before initiating the copy
'string (ActiveCell.Name = "PasteHere") and then pasting into the named cell
'(Cells("PasteHere").Paste), but that gives me an invalid procedure call or argument on:
'Cells("PasteHere").Paste I've also tried pasting into a range:Range(Cells(PasteHere, 2)
', Cells(PasteHere, 3)).Paste -AND- using the formula that is created when you a record a
'macro (Application.CutCopyMode = False) but both of those give me an application
'/object-defined error.
End If
Next i
End sub
Thank you so much in advance for reading this post and helping me out.
My Spreadsheet
End Product
This vba uses the worksheet function vlookup.
Sub ahhn()
Dim ws As Worksheet
Dim cel As Range
Set ws = ActiveSheet
With ws
For Each cel In .Range(.Range("A1"), .Range("A1").End(xlDown))
cel.Offset(0, 1) = WorksheetFunction.IfError(Application.VLookup(cel, .Range("F:H"), 2, 0), "")
cel.Offset(0, 2) = WorksheetFunction.IfError(Application.VLookup(cel, .Range("F:H"), 3, 0), "")
Next
End With
End Sub
Is it possible to transfer specific data from one worksheet to another?
What I want to do is to find all the data that has a specific string and transfer it to other worksheet. For example, I want to find data that has AC in it using the MID function, without any regards to its column and row, and transfer it to another worksheet.
So far, all I know is you need to have a specific range just like this code for it to work:
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
For Each MyCell In Range("E2:E" & LastRow)
MyCell.Value = Mid(Range("A" & MyCell.Row), 6, 2)
Next
But the thing is it only searches a certain column, what I want is to search all the data inside a worksheet. Is this possible?
The main idea is to find / search something in this worksheet that correspond to a certain criteria.
get the data.
transfer it to another worksheet.
Something like this might help you out. You may have to tweak it to your suitability.
Sub TransferAC()
Dim C As Range
For Each C In Worksheets("Sheet1").Range("A1:B3").Cells
If InStr(1, LCase(C.Value), "ac", vbTextCompare) > 0 Then
Worksheets("Sheet2").Range(C.Address).Value = C.Value
End If
Next
End Sub
To test this, create Sheet1 like so (and create an empty Sheet2):
A B
1 testing racing
2 fencing dashing
3 pacing sleeping
When you run the procedure, Sheet2 will have
A B
1 racing
2
3 pacing
EDIT
If columns and rows are unknown but we know that they start from A1, simulate doing CTRL+DOWN-arrow-key to get the last non-empty cell in the same column and CTRL+RIGHT-arrow-key from A1 to get the last non-empty cell to the right. That will be assumed as the non-empty range.
Sub TransferAC()
Dim RangeString As String
Worksheets("Sheet1").Select
Range("A1").End(xlDown).Select
RangeString = Selection.Address
Range("A1").End(xlToRight).Select
RangeString = RangeString & ":" & Selection.Address
Dim C As Range
For Each C In Worksheets("Sheet1").Range(RangeString).Cells
If InStr(1, LCase(C.Value), "ac", vbTextCompare) > 0 Then
Worksheets("Sheet2").Range(C.Address).Value = C.Value
End If
Next
End Sub
The other alternative is to give range from A1:XFD1048576 (all cells), but that may become impractical to use.
I recently posted a question, and unfortunately did not get very far with any answers. I have re-worked my macro to mirror a similar scenario I found elsewhere. The problem is I am now getting stuck at the very end.
Purpose of the macro:
1. Beneath the selected cell, I need to insert x new rows = entered months -1
In the first inserted row, I need a set of relative formulas that can be found in the Actual Row 2 of the current worksheet (basically copy and paste row 2 into the first row created)
In the subsequent inserted rows, I need a set of relative formulas that can be found in the Actual Row 3 of the current worksheet
As is, the macro does what I want, except I don't know how to paste row 3 in all subsequent rows. I'm assuming I need some conditional statement?
As mentioned in my last post, I am trying to teach myself VBA, so any help would be appreciated!!
Sub InsertMonthsAndFillFormulas(Optional vRows As Long = 0)
Dim x As Long
ActiveCell.EntireRow.Select 'So you do not have to preselect entire row
If vRows = 0 Then
vRows = Application.InputBox(prompt:= _
"Enter the total number of months in the program", Title:="Add Months", _
Default:=1, Type:=1) 'Default for 1 row, type 1 is number
If vRows = False Then Exit Sub
End If
Dim sht As Worksheet, shts() As String, i As Long
ReDim shts(1 To Worksheets.Application.ActiveWorkbook. _
Windows(1).SelectedSheets.Count)
i = 0
For Each sht In _
Application.ActiveWorkbook.Windows(1).SelectedSheets
Sheets(sht.Name).Select
i = i + 1
shts(i) = sht.Name
x = Sheets(sht.Name).UsedRange.Rows.Count 'lastcell fixup
Selection.Resize(rowsize:=2).Rows(2).EntireRow. _
Resize(rowsize:=vRows - 1).Insert Shift:=xlDown
Rows(2).EntireRow.Copy Destination:=Selection.Offset(1).Resize( _
rowsize:=1)
Rows(3).EntireRow.Copy Destination:=Selection.Offset(2).Resize( _
rowsize:=1)
On Error Resume Next
Next sht
Worksheets(shts).Select
End Sub
Ok, based on your comments, the below code should meet your needs. But first, a few things to note.
I've added several comments to help you understand what is happening in the code.
Based on your comment regarding vRows, the code will now terminate if the user keeps the default input box value ("1"). The logic is that if the value is only one, then no rows need to be added. Notice that I subtract 1 from the Inputbox value.
The code assumes you have headers or at least filled cells in row one. I use row one to find the last used column.
If there's any chance that the wrong sheet can be active when this code is executed, uncomment line 16 of my code. (Obviously you'd need to change the code to reflect your sheet's name.
Finally, this code assumes that the upper-left corner of your dataset is in A1.
Tested on Sample Dataset
Sub InsertMonthsAndFillFormulas(Optional vRows As Long = 0)
Dim lastCol As Long
Dim r As Range
'Ask user for number of months.
'If the user keeps the default value (1), exit sub.
If vRows = 0 Then
vRows = Application.InputBox(prompt:= _
"Enter the total number of months in the program", Title:="Add Months", _
Default:=1, Type:=1) - 1
If vRows = 0 Then Exit Sub
End If
'Uncomment this line if you are concerned with which sheet needs to be active.
'ThisWorkbook.Sheets("YourSheet").Select
With ActiveSheet
'Set the range to work with as the cell below the active cell.
Set r = ActiveCell.Offset(1)
'Find the last used column. (Assumes row one contains headers)
'Commented this out to hard-code the last column.
'lastCol = .Rows("1:1").Find("*", searchdirection:=xlPrevious).Column
'Insert the new rows.
r.EntireRow.Resize(vRows).Insert Shift:=xlDown
'r needs to be reset since the new rows pushed it down.
'This time we set r to be the first blank row that will be filled with formulas.
Set r = .Range(.Cells(ActiveCell.Offset(1).Row, 1), _
.Cells(ActiveCell.Offset(1).Row, "H")) '<~~ Replaced lastCol with "H"
'**Add formulas to the new rows.**
'Adds row two formulas to the first blank row.
.Range(.Cells(2, 1), .Cells(2, "H")).Copy r
'Adds row three formulas to the rest of the blank rows.
.Range(.Cells(3, 1), .Cells(3, "H")).Copy r.Offset(1).Resize(vRows - 1)
End With
End Sub
Edit
The variable lastCol is what defines the right most column to copy formulas from. This variable is set using column headers in row 1. I prefer using variables like this to make the code more robust (i.e. you can add a column to your dataset without breaking the macro), however, for this to work you need headers above every used column (or at least cells that contain values).
If you aren't concerned with adding more columns in the furture, you can hard-code the last column into the code (see my revisions).