[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

x
?
Solved

Copy row according to value in different sheet column with Macro

Posted on 2011-05-06
10
Medium Priority
?
285 Views
Last Modified: 2012-05-11
Dear All,

I have an Excel file which have 3 sheets ( Databse , Quotes , Report).
I want a Macro to check Column A in sheet (Quotes) Range (A2 :A.lastRow)
and to look for those values in sheet (Database) in Column (S) ...
If found then to copy the enitre row to sheet (Report) Range starting from (A4).


I attached a sample sheet for your ref.

If possible to make it in a new vision like copy all rows from Database sheet to Report sheet then make the application.screenupdate =true while deleting the others rows which do not equal to Column A in sheet (Quotes) .. i hope you get my point , when the macro run it will show how the rows are nicely pasted on the sheet report like someone is typing them ;)
Anyway this is not a must .. but would appreciate it a lot.

Thanks and Brgds
Wellous


Tracker.xls
0
Comment
Question by:wellous
10 Comments
 
LVL 18

Assisted Solution

by:krishnakrkc
krishnakrkc earned 400 total points
ID: 35708401
Hi,

Try this.


Kris
Sub kTest()
Dim wksQuotes   As Worksheet
Dim wksDB       As Worksheet
Dim wksReport   As Worksheet
Dim LastRow     As Long
Dim Data, Quotes
Dim dicQuotes   As Object
Dim i           As Long
Dim n           As Long
Dim c           As Long
Dim FormatRowNo As Long
Dim arrOutput()

Set wksQuotes = Worksheets("Quotes")
Set wksDB = Worksheets("Database")
Set wksReport = Worksheets("Report")

With wksDB
    Data = Intersect(.UsedRange, .Range("a:cv"))
End With

Const QuoteCol      As Long = 19 'Col S

With wksQuotes
    Quotes = Intersect(.UsedRange, .Columns(1))
End With

Set dicQuotes = CreateObject("scripting.dictionary")
    dicQuotes.comparemode = 1

For i = 2 To UBound(Quotes, 1)
    If Len(Quotes(i, 1)) Then
        dicQuotes.Item(Quotes(i, 1)) = Empty
    End If
Next

If dicQuotes.Count Then
    ReDim k(1 To dicQuotes.Count, 1 To UBound(Data, 2))
    For i = 4 To UBound(Data, 1)
        If dicQuotes.exists(Data(i, QuoteCol)) Then
            n = n + 1
            For c = 1 To UBound(Data, 2)
                If (c = 16) + (c = 17) Then
                    If Len(Data(i, c)) = 0 Then
                        k(n, c) = wksDB.Cells(i, c).MergeArea.Cells(1).Value2
                        FormatRowNo = wksDB.Cells(i, c).MergeArea.Cells(1).Row
                    Else
                        k(n, c) = Data(i, c)
                    End If
                Else
                    k(n, c) = Data(i, c)
                End If
            Next
        End If
    Next
    If n Then
        With wksReport
            LastRow = .Range("a" & .Rows.Count).End(xlUp).Row
            LastRow = Application.Max(4, LastRow + 1)
            .Range("a" & LastRow).Resize(n, UBound(k, 2)).Value = k
            wksDB.Rows(FormatRowNo).Copy
            .Range("a" & LastRow).Resize(n).EntireRow.PasteSpecial -4122
            .Range("o" & LastRow).Copy
            With .Range("p" & LastRow).Resize(n, 2)
                .PasteSpecial -4122
                .NumberFormat = "dd-mm-yyyy"
            End With
        End With
        Application.CutCopyMode = 0
    End If
End If

End Sub

Open in new window

0
 
LVL 24

Assisted Solution

by:StephenJR
StephenJR earned 400 total points
ID: 35708434
Not sure what you mean by the second part, but does this do what you want? The code could be more efficient if the blank rows were removed from the Database sheet.
Sub x()

Dim r1 As Range, r2 As Range, r3 As Range, r4 As Range

With Sheets("Quotes")
    Set r1 = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
End With

With Sheets("Database")
    Set r2 = .Range("S4", .Range("S" & Rows.Count).End(xlUp))
End With

For Each r3 In r1
    For Each r4 In r2
        If r4 = r3 Then r4.EntireRow.Copy Sheets("Report").Range("A" & Rows.Count).End(xlUp)(2)
    Next r4
Next r3

End Sub

Open in new window

0
 
LVL 8

Expert Comment

by:wchh
ID: 35710504
Amended Macro  from previous comment?
Sub x()

Dim r1 As Range, r2 As Range, r3 As Range, r4 As Range

With Sheets("Quotes")
    Set r1 = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
End With

With Sheets("Database")
    Set r2 = .Range("S4", .Range("S" & Rows.Count).End(xlUp))
End With

Sheets("Report").Range("4:" & Rows.Count).EntireRow.Delete
For Each r3 In r1
    For Each r4 In r2
        If r4 = r3    r4.EntireRow.Copy Sheets("Report").Range("A" & Sheets("Report").UsedRange.Rows.Count + 1)
    Next r4
Next r3

End Sub

Open in new window

0
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
LVL 8

Expert Comment

by:wchh
ID: 35710507

Sub x()

Dim r1 As Range, r2 As Range, r3 As Range, r4 As Range

With Sheets("Quotes")
    Set r1 = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
End With

With Sheets("Database")
    Set r2 = .Range("S4", .Range("S" & Rows.Count).End(xlUp))
End With

Sheets("Report").Range("4:" & Rows.Count).EntireRow.Delete
For Each r3 In r1
    For Each r4 In r2
        If r4 = r3 then r4.EntireRow.Copy Sheets("Report").Range("A" & Sheets("Report").UsedRange.Rows.Count + 1)
    Next r4
Next r3

End Sub

Open in new window

0
 
LVL 5

Author Comment

by:wellous
ID: 35712181
Thank you ALL,
@Kris : Your code is working perfect :) your way about handling the dates and data types is great.
@StephenJR : Unfortunately , the database has blank rows ( lots)... your code brings first row only.
@ wchh: After you modified Stephan's code it works very well..

Can i make a little modification ? what if the user puts a quote which is not in database?
Whenever the quote is not found in database i want to write " quote not found" .

I tried to add this line of code  after line 16 of Wchh's code :
Else: Sheets("Report").Range("A" & Sheets("Report").UsedRange.Rows.Count) = "quote not found"
the macro starts to run slowly like the data is being written or slowly pasted row by row .. i love it :)
but it's putting "quote not found"  in the beginning of all report rows :(


Many thanks for your great support.
Wish you the best.
Wellous
0
 
LVL 5

Author Comment

by:wellous
ID: 35712263
Sorry if i couldn't explain very well .
To write " quote not found" in Report sheet , it's much better if the code can bring the quote value from the sheet ( Quotes) and write beside it " quote not found" in its row, So let's say in
sheet Report Range A to write the quote value taken from sheet ( Quotes) and in Range B to write " quote not found".

Thanks again.
Wellous
0
 
LVL 8

Expert Comment

by:wchh
ID: 35717010

Sub x()

Dim r1 As Range, r2 As Range, r3 As Range, r4 As Range
Dim Cnt As Long

With Sheets("Quotes")
    Set r1 = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
End With

With Sheets("Database")
    Set r2 = .Range("S4", .Range("S" & Rows.Count).End(xlUp))
End With

Sheets("Report").Range("4:" & Rows.Count).EntireRow.Delete

For Each r3 In r1
    Cnt = 0
    For Each r4 In r2
       If r4 = r3 Then
       r4.EntireRow.Copy Sheets("Report").Range("A" & Sheets("Report").UsedRange.Rows.Count + 1)
       Cnt = Cnt + 1
       End If
    Next r4
    If Cnt = 0 Then
       Sheets("Report").Range("B" & Sheets("Report").UsedRange.Rows.Count + 1).Value = "quote not found"
       Sheets("Report").Range("S" & Sheets("Report").UsedRange.Rows.Count).Value = r3.Value
    End If
Next r3

End Sub

Open in new window

0
 
LVL 5

Author Comment

by:wellous
ID: 35717085
Thank you wchh , the code is running very well, but the entire row is not formated !
Can we formate it ? let's say to make the entire row red .

this is my last dimand hopefully ;) and then will give you the points.
Many thanks for your support
Much Appreciated,
Wellous
0
 
LVL 8

Accepted Solution

by:
wchh earned 1200 total points
ID: 35717127

Sub x()

Dim r1 As Range, r2 As Range, r3 As Range, r4 As Range
Dim Cnt As Long

With Sheets("Quotes")
    Set r1 = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
End With

With Sheets("Database")
    Set r2 = .Range("S4", .Range("S" & Rows.Count).End(xlUp))
End With

Sheets("Report").Range("4:" & Rows.Count).EntireRow.Delete

For Each r3 In r1
    Cnt = 0
    For Each r4 In r2
       If r4 = r3 Then
       r4.EntireRow.Copy Sheets("Report").Range("A" & Sheets("Report").UsedRange.Rows.Count + 1)
       Cnt = Cnt + 1
       End If
    Next r4
    If Cnt = 0 Then
       Sheets("Report").Range("B" & Sheets("Report").UsedRange.Rows.Count + 1).Value = "quote not found"
       Sheets("Report").Range("S" & Sheets("Report").UsedRange.Rows.Count).Value = r3.Value
       Sheets("Report").Range("S" & Sheets("Report").UsedRange.Rows.Count).EntireRow.Interior.Color = RGB(255, 0, 0)
    End If
Next r3

End Sub

Open in new window

0
 
LVL 5

Author Closing Comment

by:wellous
ID: 35721136
Thank you :)
0

Featured Post

Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
Access developers frequently have requirements to interact with Excel (import from or output to) in their applications.  You might be able to accomplish this with the TransferSpreadsheet and OutputTo methods, but in this series of articles I will di…
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.
Although Jacob Bernoulli (1654-1705) has been credited as the creator of "Binomial Distribution Table", Gottfried Leibniz (1646-1716) did his dissertation on the subject in 1666; Leibniz you may recall is the co-inventor of "Calculus" and beat Isaac…

872 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question