How to copy and paste chosen columns based on two criteria
Category: [Excel] Demo Available
How to copy and paste chosen columns based on two criteria
Requirement:
The user has a "table" with basketball games and referees. in columns 9 and 10 the referees are listed.
The user wants to search the two columns 9 and 10, row by row for a name. If the name is found in a row then copy chosen cells and paste them on sheet2.
This is the code:
Code:
'dim
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lR As Long, eR As Long, i As Integer ' lR=last row eR=first empty row
Dim name As String 'name=referee
'set
Set ws1 = Sheet1
Set ws2 = Sheet2
lR = ws1.Cells(Rows.Count, 1).End(xlUp).Row
eR = ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
name = ws1.Range("M1").Value
For i = 2 To lR
If ws1.Cells(i, "I").Value = name Or ws1.Cells(i, "J").Value = name Then
ws1.Cells(i, 1).Copy
ws1.Paste Destination:=ws2.Cells(eR, 3)
ws1.Cells(i, 6).Copy
ws1.Paste Destination:=ws2.Cells(eR, 1)
ws1.Cells(i, 7).Copy
ws1.Paste Destination:=ws2.Cells(eR, 2)
ws1.Cells(i, 8).Copy
ws1.Paste Destination:=ws2.Cells(eR, 4)
ws1.Cells(i, 9).Copy
ws1.Paste Destination:=ws2.Cells(eR, 5)
ws1.Cells(i, 10).Copy
ws1.Paste Destination:=ws2.Cells(eR, 6)
End If
Next i
ws2.Columns.AutoFit
ws2.Select
It only finds 1 of 3 entries in column 9, and find 0 of 4 entries in column 10.
Solution:
Code:
Option Explicit
Sub FindRef()
Dim s As Worksheet, t As Worksheet
Set s = Sheets("Våren -17")
Set t = Sheets("Sheet1")
'Dim c As Range, rng As Range
Dim lr As Long, lr2 As Long, i As Long
lr = s.Range("I" & Rows.Count).End(xlUp).Row
'Set rng = s.Range("I2:J" & lr)
Dim Ref As String
Ref = s.Range("M1")
Application.ScreenUpdating = False
For i = 2 To lr
lr2 = t.Range("A" & Rows.Count).End(xlUp).Row + 1
If s.Range("I" & i) = Ref Or s.Range("J" & i) = Ref Then
s.Range("F" & i & ":G" & i).Copy t.Range("A" & lr2)
Application.Union(s.Range("A" & i), s.Range("H" & i & ":J" & i)).Copy t.Range("C" & lr2)
End If
Next i
Application.CutCopyMode = True
Application.ScreenUpdating = True
MsgBox "complete"
End Sub
Obtained from the OzGrid Help Forum.
Solution provided by AlanSidman.
See also: Index to Excel VBA Code and Index to Excel Freebies and Lesson 1 - Excel Fundamentals and Index to how to… providing a range of solutions and Index to new resources and reference sheets
See also:
| How to copy/paste between workbooks with relative referencing |
| How to copy a sheet and rename from a list, ignore duplicates |
| How to use VBA code to copy Active Row cells to another sheet |
| How to create VBA code to increment number each time a copy is printed |
Click here to visit our Free 24/7 Excel/VBA Help Forum where there are thousands of posts you can get information from, or you can join the Forum and post your own questions.