Solved

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

Posted on 2008-10-11
9
225 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
ID: 22696113
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
ID: 22696477
Thanks, but still only getting a singe column. Any other ideas?
0
 

Author Comment

by:guacolizard
ID: 22696562
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
ID: 22697905
Nevermind, that didn't work...at this point I am open to any suggestions. Thanks.
0
Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

 
LVL 23

Expert Comment

by:irudyk
ID: 22698484
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
ID: 22698899
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
ID: 22698935
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
ID: 22699049
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
ID: 31505542
Thank you much!
0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

When designing a form there are several BorderStyles to choose from, all of which can be classified as either 'Fixed' or 'Sizable' and I'd guess that 'Fixed Single' or one of the other fixed types is the most popular choice. I assume it's the most p…
Since upgrading to Office 2013 or higher installing the Smart Indenter addin will fail. This article will explain how to install it so it will work regardless of the Office version installed.
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…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

863 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

25 Experts available now in Live!

Get 1:1 Help Now