Solved

Program is only outputting one cell of a row, need to output entire row...

Posted on 2008-10-11
9
212 Views
Last Modified: 2011-10-19
I need to figure out how to output the entire row of the matched cell. The program works it only outputs the exact matched cell. The problem is I also need the info in the cells to the left and right of the same row in the output file. Please, if possible provide an explanation so I can see what was missing. I still trying to learn. Thanks in advance.
Private Sub Exit_Click()

Me.Hide

End Sub
 

Private Sub Open_Click()
 

Dim xlApp As Excel.Application

Dim xlBook As Excel.Workbook

Dim strPath As String, strFile1 As String, strFile2 As String

Dim wbkThis As Workbook, wbk1 As Workbook, wbk2 As Workbook

Dim wksDest As Worksheet, wksSource As Worksheet, wksCheck As Worksheet

Dim rngMatch As Range, rngCheck As Range, rngFound As Range, rngCopy As Range
 

  CommonDialog1.flags = cdlOFNExplorer Or cdlOFNLongNames

  CommonDialog1.FileName = ""

  CommonDialog1.Filter = "Excel Files (*.xls)|*.xls|"

  CommonDialog1.DialogTitle = "Browse for file"

  CommonDialog1.ShowOpen
 

Set xlApp = CreateObject("Excel.Application")

xlApp.Visible = True

Set xlBook = xlApp.Workbooks.Open(CommonDialog1.FileName)
 

    Set wbkThis = Workbooks.Add

    Set wbk1 = xlBook

    Set wbk2 = Excel.Workbooks.Open("c:\Users\User1.xls")

   

    'Change sheet names as required

   

    ' This is the sheet to copy to

    Set wksDest = wbkThis.Sheets("Sheet1")

    ' This is the sheet in XLS1

    Set wksSource = wbk1.Sheets(1)

    Set wksCheck = wbk2.Sheets(1)

     
 

    ' Get first blank row in main workbook to copy to

    With wksDest

        Set rngCopy = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)

    End With

    ' First cell to check in XLS1

    Set rngMatch = wksSource.Range("D1")

    ' Set check range to all used cells in column A of XLS2

    With wksCheck

        Set rngCheck = wksCheck.Range("a2")

        'Set rngCheck = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))

    End With

    ' Loop through cells in column A of XLS1 until a blank cell is encountered

    Do Until Len(rngMatch.value) = 0

        Set rngFound = rngCheck.Find(what:=rngMatch.value, LookIn:=xlValues, lookat:=xlWhole)

        If Not rngFound Is Nothing Then

            ' Copy data from XLS2 to this workbook

            rngFound.Copy rngCopy

            Set rngCopy = rngCopy.Offset(1, 0)

        End If

        Set rngMatch = rngMatch.Offset(1, 0)

    Loop

    wbk1.Close False

    wbk2.Close False

    wbkThis.Save

End Sub

Open in new window

ToSearch.xls
User1.xls
0
Comment
Question by:guacolizard
  • 5
  • 4
9 Comments
 
LVL 23

Expert Comment

by:irudyk
Comment Utility
Try changing line 53 of the code you posted above from
    rngFound.Copy rngCopy
to
    wksCheck.Rows(rngFound.Row).Copy rngCopy
rngFound.Row return the row number of the found cell and wksCheck.Rows(rngFound.Row).Copy will copy that entire row
0
 

Author Comment

by:guacolizard
Comment Utility
Thanks, but still only getting a singe column. Any other ideas?
0
 

Author Comment

by:guacolizard
Comment Utility
Okay I added your line and then swapped the source and check around. I got a little further. I just need to figure out how to make it only search the one column and stop.
 Set wksDest = wbkThis.Sheets("Sheet1")

    ' This is the sheet in XLS1

    Set wksSource = wbk2.Sheets(1)

    ' This is the sheet in XLS2 to compare against

    Set wksCheck = wbk1.Sheets(1)
 

    ' Get first blank row in main workbook to copy to

    With wksDest

        Set rngCopy = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)

    End With

    ' First cell to check in XLS1

    Set rngMatch = wksSource.Range("A2")

    ' Set check range to all used cells in column A of XLS2

    With wksCheck

        Set rngCheck = wksCheck.Range("E9")

        'Set rngCheck = wksCheck.Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))

    End With

    ' Loop through cells in column A of XLS1 until a blank cell is encountered

    Do Until Len(rngMatch.value) = 0

        'Set rngFound = rngCheck.Find(what:=rngMatch.value, LookIn:=xlValues, lookat:=xlWhole)

        Set rngFound = rngCheck.Find(what:=rngMatch.value, LookAt:=xlWhole, LookIn:=xlValues, SearchOrder:=xlByColumns)

        If Not rngFound Is Nothing Then

            ' Copy data from XLS2 to this workbook

            wksCheck.Rows(rngFound.Row).Copy rngCopy

            Set rngCopy = rngCopy.Offset(1, 0)

        End If

        Set rngMatch = rngMatch.Offset(1, 0)

Open in new window

0
 

Author Comment

by:guacolizard
Comment Utility
Nevermind, that didn't work...at this point I am open to any suggestions. Thanks.
0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 
LVL 23

Expert Comment

by:irudyk
Comment Utility
I think you're going to have to clarify things a little bit more.  Your code it copying the information from the User1.xls (which has nothing but a number value in column A) into a new workbook based upon a value search where the value is being pulled from the ToSearch.xls (column D).  Using my revided code I do get the full row being copied into the new workbook, but as I stated, since this copying is from the User1.xls which only has info in column A, there is nothing else that would show up in the new workbook.  I somehow doubt that this is what youwant to happen.
What would be helpful here is to give a specific example of exactly what you want to happen and even provide a sample file showing what output you are expecting to see.
0
 

Author Comment

by:guacolizard
Comment Utility
Thanks for responding. Okay, what I would like to do is use the user1.xls file to locate the the values in the "E" column of ToSearch.xls and once they are located extract the entire row associated with that value. The output would look similar to the file below (but obviously not exact).
Book1.xls
0
 
LVL 23

Expert Comment

by:irudyk
Comment Utility
Okay, your ToSearch.xls file posted has the info in column D not E...have you added an extra blank column to the ToSearch.xls file or did you need a blank column inserted in the new file the info is being copied to?
0
 
LVL 23

Accepted Solution

by:
irudyk earned 500 total points
Comment Utility
Well based upon the the original files posted, give the following code a try to see if it is retrieving the information you are looking for:
Private Sub Exit_Click()

Me.Hide

End Sub

 

Private Sub Open_Click()

 

Dim xlApp As Excel.Application

Dim xlBook As Excel.Workbook

Dim strPath As String, strFile1 As String, strFile2 As String

Dim wbkThis As Workbook, wbk1 As Workbook, wbk2 As Workbook

Dim wksDest As Worksheet, wksSource As Worksheet, wksCheck As Worksheet

Dim rngMatch As Range, rngCheck As Range, rngFound As Range, rngCopy As Range

 

  CommonDialog1.flags = cdlOFNExplorer Or cdlOFNLongNames

  CommonDialog1.Filename = ""

  CommonDialog1.Filter = "Excel Files (*.xls)|*.xls|"

  CommonDialog1.DialogTitle = "Browse for file"

  CommonDialog1.ShowOpen

 

Set xlApp = CreateObject("Excel.Application")

xlApp.Visible = True

Set xlBook = xlApp.Workbooks.Open(CommonDialog1.Filename)

 

    Set wbkThis = Workbooks.Add

    Set wbk1 = xlBook

    Set wbk2 = Excel.Workbooks.Open("c:\Users\User1.xls")

   

    'Change sheet names as required

   

    ' This is the sheet to copy to

    Set wksDest = wbkThis.Sheets("Sheet1")

    ' This is the sheet in XLS1

    Set wksSource = wbk1.Sheets(1)

    Set wksCheck = wbk2.Sheets(1)

 

    ' Get first blank row in main workbook to copy to

    With wksDest

        Set rngCopy = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)

    End With

    ' column to check in wksSource

    Set rngMatch = wksSource.Range("D:D")

    ' Set check range to all used cells in column A of wksCheck

    Set rngCheck = wksCheck.Range("a2")

    ' Loop through cells in column A of wksCheck until a blank cell is encountered

    Do Until Len(rngCheck.Value) = 0

        Set rngFound = rngMatch.Find(what:=rngCheck.Value, LookIn:=xlValues, lookat:=xlWhole)

        If Not rngFound Is Nothing Then

            ' Copy data from wksSource to wksDest

            wksSource.Rows(rngFound.Row).Copy rngCopy

            Set rngCopy = rngCopy.Offset(1, 0)

        End If

        Set rngCheck = rngCheck.Offset(1, 0)

    Loop

    wbk1.Close False

    wbk2.Close False

    wbkThis.Save

End Sub

Open in new window

0
 

Author Closing Comment

by:guacolizard
Comment Utility
Thank you much!
0

Featured Post

Why You Should Analyze Threat Actor TTPs

After years of analyzing threat actor behavior, it’s become clear that at any given time there are specific tactics, techniques, and procedures (TTPs) that are particularly prevalent. By analyzing and understanding these TTPs, you can dramatically enhance your security program.

Join & Write a Comment

Introduction While answering a recent question (http://www.experts-exchange.com/Q_27402310.html) in the VB classic zone, I wrote some VB code in the (Office) VBA environment, rather than fire up my older PC.  I didn't post completely correct code o…
Have you ever wanted to restrict the users input in a textbox to numbers, and while doing that make sure that they can't 'cheat' by pasting in non-numeric text? Of course you can do that with code you write yourself but it's tedious and error-prone …
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…

744 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

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now