Copy specific rows from one sheet to another

[theiguy]

I have some experience with VBA, but mostly editing recorded Macros or modifying other code I've found. This is an overview of what I'm trying to do, but haven't had much success.

Sheet 1 named “Work Sheet”
Sheet 2 named “Data”
Sheet 3 named “Temp”

Sheet 1 has a drop down list of 10 different companies
Sheet 2 has all the data for the companies, contact, address, etc. Column O has the company name in it.
Sheet 3 is an empty template of Sheet 2

The idea is that I want to pick a company from the drop down on Sheet 1 and copy all the data in Range A : P for that company from Sheet 2 to Sheet 3.

All the data in Sheet 2 is already organized by company, but some companies are a single row where others are 10 rows.

I know that I have to store the company from the drop down on Sheet 1 as an integer and then pass it along. And that I’ll have to use an .endup for sheet 2 to find all the rows with that particular company, but I don’t know how to do the find copy and paste work.

Any help would be awesome!

 

[ravishankar]

Hi
Paste the following codes in the macro window ( alt F11 Insert > module)

Sub company()
Dim  y As Long, a As Long, d As Long
d = 2
y = Worksheets("Data").Cells(Rows.Count, 15).End(xlUp).Row
For a = 2 To y
If Worksheets("Work Sheet").Cells(1, 1) = Worksheets("Data").Cells(a, 15) Then
Worksheets("Data").Range("A" & a & ":P" & a).Copy
Worksheets("Temp").Range("A" & d).PasteSpecial
d = d + 1
End If
Next a
End Sub

I assume drop down is in A1 of work sheet
Ravi

 

[theiguy]

Couldn't get it to work. No errors, just didn't do anything. I found another peice of code that was helpful:

Sub CopyAll()

Sheets("Data Entry").Select

Dim LR As Integer
Dim LR2 As Integer
Dim x As Range
LR = Range("A" & Rows.Count).End(xlUp).Row
For Each x In Range("T3:T" & LR)
If InStr(1, x.Value, "Golden", 1) > 0 Then
x.EntireRow.Copy
Sheets("Temp").Select
LR2 = Range("A" & Rows.Count).End(xlUp).Row
Cells(LR2 + 1, 1).PasteSpecial
End If
Next x
End Sub

I want to replace where is uses "Golden" with the text from a drop down on Sheet 1. The drop down is in cell D4.

 

[gkimber2]

have you considered filtering based on the value in the drop down box?

here's a little piece of a macro where I do something similar, although the filter value is predetermined.

    Selection.AutoFilter Field:=1, Criteria1:="Dog"
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Dog").Select
    ActiveSheet.Paste
    Cells.Select
    Cells.EntireColumn.AutoFit
    Rows("2:2").Select
    ActiveWindow.FreezePanes = True
    Range("A1").Select

 

[theiguy]

have you considered filtering based on the value in the drop down box?

here's a little piece of a macro where I do something similar, although the filter value is predetermined.

    Selection.AutoFilter Field:=1, Criteria1:="Dog"
    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Dog").Select
    ActiveSheet.Paste
    Cells.Select
    Cells.EntireColumn.AutoFit
    Rows("2:2").Select
    ActiveWindow.FreezePanes = True
    Range("A1").Select

I played around with your suggestion a bit, didn't do what I was looking for. Thanks though.

Any other ideas?

 

[theiguy]

*BUMP*

Couldn't get it to work. No errors, just didn't do anything. I found another peice of code that was helpful:

Sub CopyAll()

Sheets("Data Entry").Select

Dim LR As Integer
Dim LR2 As Integer
Dim x As Range
LR = Range("A" & Rows.Count).End(xlUp).Row
For Each x In Range("T3:T" & LR)
If InStr(1, x.Value, "Golden", 1) > 0 Then
x.EntireRow.Copy
Sheets("Temp").Select
LR2 = Range("A" & Rows.Count).End(xlUp).Row
Cells(LR2 + 1, 1).PasteSpecial
End If
Next x
End Sub

I want to replace where is uses "Golden" with the text from a drop down on Sheet 1. The drop down is in cell D4.

Still trying to replace "Golden." Any other thoughts?

 

[theiguy]

Got it to work. Here is my correct code:

Dim LR As Integer
Dim LR2 As Integer
Dim x As Range
Dim wrd As String
LR = Range("A" & Rows.Count).End(xlUp).Row

wrd = Sheets("Work Sheet").Range("D4").Text

For Each x In Range("T3:T" & LR)
If InStr(1, x.Value, wrd, 1) > 0 Then
x.EntireRow.Copy
Sheets("Temp").Select
LR2 = Range("A" & Rows.Count).End(xlUp).Row
Cells(LR2 + 1, 1).PasteSpecial
End If
Next x