Am I being Ignored, or is my problem too hard?

[sharpie23]

I ahve posted a 3 times over the past 2 days the same problem and have
gotten no respones.
If no one knows how, or it is not possible, Please let me know.

Any response is a good resonse at this point

Again here is my problem.


I am trying to write a Sub that will lookup the 36-40 file names on
sheet(2) column E of my MAIN wrkbook. It will then go into each of the
36-40 wrkbooks , sheet(1) of each wrkbook, and search down column K.
Everywhere there is a "Q" in a column it will copy all info in that row



(from column A to H) and then paste that info on Sheet(3) of the MAIN
wrkbook. Obviously each new paste will need to be placed at the first
empty row.


Thanks
Ryan

 

[Dave Peterson]

Not tested much -- but it did compile.

Option Explicit
Sub testme()

Dim TempWks As Worksheet
Dim myCell As Range
Dim DestCell As Range
Dim InputRng As Range
Dim TempCell As Range
Dim TempRngToCheck As Range

With Worksheets("sheet2")
Set InputRng = .Range("E1", .Cells(.Rows.Count, "E").End(xlUp))
End With

With Worksheets("sheet3")
'column A of the next row (based on column K
Set DestCell = .Cells(.Rows.Count, "K").End(xlUp).Offset(1, -10)
End With

For Each myCell In InputRng.Cells
Set TempWks = Nothing
On Error Resume Next
Set TempWks = Workbooks.Open(Filename:=myCell.Value).Worksheets(1)
On Error GoTo 0

If TempWks Is Nothing Then
myCell.Offset(0, 1).Value = "Missing file!"
Else
With TempWks
Set TempRngToCheck _
= .Range("k1", .Cells(.Rows.Count, "K").End(xlUp))
End With
For Each TempCell In TempRngToCheck.Cells
If LCase(TempCell.Value) = LCase("Q") Then
'found a match
TempCell.EntireRow.Resize(1, 8).Copy _
Destination:=DestCell
Set DestCell = DestCell.Offset(1, 0)
End If
Next TempCell
TempWks.Parent.Close savechanges:=False
myCell.Offset(0, 1).Value = "Done"
End If
Next myCell

End Sub

 

[Bruno Campanini]

I ahve posted a 3 times over the past 2 days the same problem and have
gotten no respones.
If no one knows how, or it is not possible, Please let me know.

Any response is a good resonse at this point

Again here is my problem.


I am trying to write a Sub that will lookup the 36-40 file names on
sheet(2) column E of my MAIN wrkbook. It will then go into each of the
36-40 wrkbooks , sheet(1) of each wrkbook, and search down column K.
Everywhere there is a "Q" in a column it will copy all info in that row



(from column A to H) and then paste that info on Sheet(3) of the MAIN
wrkbook. Obviously each new paste will need to be placed at the first
empty row.

Hi Ryan,
I think the following does your job:
=============================
Sub MuiltipleSearch()
' Make a search over one or more columns, even not contiguous,
' from one or more workbooks listed in this table,
' located in ActiveSheet (you can list here your 40 Workbooks):
'
Top Left
' Filename with path Sheet Cell Address
' ----------------------------------------------------------------
' C:\Document\Excel\XLS\BBCC1.XLS Sheet1 A20
' C:\Document\Excel\XLS\BBCC2.XLS Sheet2 D18
' C:\Document\Excel\XLS\BBCC3.XLS Sheet3 B5
'
' ListCell is the cell containing the first Filename.
'
Dim ListCell As Range, WorkbookLoaded As Boolean
Dim i, s, j As Long, n As Long, k As Long
Dim SearchColumns As Byte, NumColumns As Byte
Dim KeyArray(), MatchFound As Byte
Dim SourceCell As Range, TargetCell As Range
Dim SourceSheet As Worksheet, TargetSheet As Worksheet
Dim FinalSort As Boolean

' User Definitions
' ----------------------------------------------------
Set TargetSheet = Sheets("Sheet1")
Set TargetCell = TargetSheet.[I14]
Set ListCell = ActiveSheet.[B5]
SearchColumns = 1 ' Number of columns to serach in
NumColumns = 11 ' From A to K, we must include the I, J empty ones.
' If it is a problem for you I will modify
code.
ReDim KeyArray(1 To SearchColumns, 1 To 2)
' KeyArray(n, 1) column number (n) to search in
' KeyArray(n, 2) search Key for the n-th column
KeyArray(1, 1) = 11 ' which corresponds to column K
KeyArray(1, 2) = "Q" ' search Key for column K
'KeyArray(2, 1) = 4 ' ordinal for additionale search Key
'KeyArray(2, 2) = "latte" ' additional search Key
FinalSort = True ' True | False (see below)
' -----------------------------------------------------

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
On Error GoTo ErrHandler

For Each s In Range(ListCell, ListCell.End(xlDown))
For Each i In Workbooks
If i.Name = s Then
WorkbookLoaded = True
End If
Next
If WorkbookLoaded Then
WorkbookLoaded = False
Else
Workbooks.Open (s)
Set SourceSheet = Sheets(s.Offset(0, 1).Value)
Set SourceCell = SourceSheet.Range(s.Offset(0, 2))
End If
For Each i In Range(SourceCell, SourceCell.End(xlDown))
n = n + 1
MatchFound = 0
For j = 1 To SearchColumns
If i.Offset(0, KeyArray(j, 1) - 1) = KeyArray(j, 2) Then
MatchFound = MatchFound + 1
End If
Next
If MatchFound = SearchColumns Then
Range(TargetSheet.Cells(TargetCell.Row + k, TargetCell.Column),
_
TargetSheet.Cells(TargetCell.Row + k, TargetCell.Column +
NumColumns - 1)) = _
Range(i, i.Offset(0, NumColumns - 1)).Value
k = k + 1
End If
Next
ActiveWorkbook.Close SaveChanges:=False
Next

' You must define here Sort parameters (Max 3)
If FinalSort Then
Range(TargetCell, TargetCell.End(xlDown). _
Offset(0, NumColumns - 1)).Sort _
Key1:=TargetCell.Offset(-1, 2), _
Order1:=xlAscending, _
Key2:=TargetCell.Offset(-1, 4), _
Order2:=xlDescending, _
Orientation:=xlSortColumns, _
MatchCase:=True, _
Header:=xlNo
End If

Exit_Sub:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Exit Sub

ErrHandler:
MsgBox "Error: " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
"Procedure: " & "Sub MuiltipleSearch()" & vbCrLf &
ThisWorkbook.FullName
Resume Exit_Sub

End Sub
================================
Let me know how it works for you.
Try without any care: it doesn't modify your
source data.

Ciao
Bruno

 

[Barb Reinhardt]

THis may help you get some of it. I'm not a programming expert so would
rather let others answer your question more specifically.