Need help: find value from different workbooks and worksheets and copy in master data sheet

[Leflex666]

[/HTML]Hello all! I am new to this forum and hope someone can help me to sort out my problem. I have in a file over 20 workbooks (p.e. Benutzerform 1) with different worksheets (Input, Project 1, Project 2,...) and in a other file a master data workbook (Mappe 1). In the master data workbook I can choose the name of the project and the month. In the different workbooks (Benutzerform #) and sheets finds the project and the month. In the master data workbook will be created a new sheet called "Auswertung" and placed in each row the user name and the month and project. Column a the user name and column b the month and project. Till here I could create the vba. I would like that from column c it copy as well the corresponding data of the found match. But unfortunatly I have no idea how I can do it. Maybe someon is able to help me. Thank you in advance for any suggestion! Please find below the code:

[CODE]Option Explicit
Sub Ausw()
    Dim SumSh As Worksheet
    Dim fPath As String ' path of the file
    Dim fName As String ' fiename
    Dim wb As Workbook ' workbooks
    Dim drng As Range 'dest range
    Dim srng As Range 'source range
    Dim Ws As Worksheet ' worksheets
    Dim FindString As String 'find the match
    Dim lngLastRow As Range 'row
   
    FindString = Sheets("Tabelle1").Range("a8") 'source of match
    Set SumSh = Worksheets.Add 'add new sheet
    ActiveSheet.Name = "Auswertung" ' name of new sheet
    fPath = "C:\Users\pa054756\Desktop\WTS Probe - Kopie\" ' file path
    fName = Dir(fPath & "*.xl*")
     
    Do While fName <> ""
        Set wb = Workbooks.Open(fPath & fName)
        SumSh.Range("A" & Rows.Count).End(xlUp)(2).Value = Sheets("input").Range("b3") 'source for person
        
        'lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row 'row
        
        For Each Ws In ActiveWorkbook.Worksheets
            
            If Trim(FindString) <> "" Then
With Ws.Columns(3) '("c:C" & lngLastRow)
            Set srng = .Find(What:=FindString, After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True) 'what to find
          End With
          If Not srng Is Nothing Then
            Set drng = SumSh.Range("B" & Rows.Count).End(xlUp)(2)
            Set drng = drng.Resize(srng.Rows.Count, srng.Columns.Count)
            drng.Value = srng.Value
             End If
            End If
        Next Ws
        wb.Close False
         
        fName = Dir()
    Loop
End Sub

[/CODE]

 

[Leflex666]

[/PHP]Can someon help me please! I am desperated and don't find any solution. Thank u in advance for any advice. [/PHP]

 

[Leflex666]

Is there someone who can help me please?

 

[shg]

Maybe ...

Option Explicit
 
Sub Ausw()
    Const sPath     As String = "C:\Users\pa054756\Desktop\WTS Probe - Kopie\"
    Dim sFile       As String       ' filename
    Dim sWhat       As String       ' string to find
    Dim rFind       As Range        ' location where found

    Dim wksSum      As Worksheet    ' summary sheet
    Dim wks         As Worksheet    ' worksheet loop variable

    sWhat = Trim(Sheets("Tabelle1").Range("A8").Value2)    'source of match
    If Len(sWhat) = 0 Then Exit Sub

    Set wksSum = Worksheets.Add    'add new sheet
    ActiveSheet.Name = "Auswertung"

    sFile = Dir(sPath & "*.xl*")

    Do While Len(sFile)
 
        With Workbooks.Open(sPath & sFile)
            wksSum.Cells(Rows.Count, "A").End(xlUp)(2).Value = .Worksheets("input").Range("B3").Value

            For Each wks In ActiveWorkbook.Worksheets
                With wks.Columns("C")
                    Set rFind = .Find(What:=sWhat, _
                                      After:=.Cells(.Cells.Count), _
                                      LookIn:=xlValues, _
                                      LookAt:=xlWhole, _
                                      SearchOrder:=xlByRows, _
                                      SearchDirection:=xlNext, _
                                      MatchCase:=True)
                End With

                If Not rFind Is Nothing Then
                    rFind.Resize(, 2).Copy wksSum.Cells(Rows.Count, "B").End(xlUp)(2)
                End If
            Next wks

            .Close SaveChanges:=False
        End With

        sFile = Dir()
    Loop
End Sub

 

[Leflex666]

Thank you so much for your help,

the code is great and exactly what I hoped for. It is possible to copy just the value without formula? I the following code would be perfect to copy without formula.

  rFind.Resize(, 10).Copy wksSum.Cells(Rows.Count, "B").End(xlUp)(2)

As the copied range has formulas, it can't find the link to the linked cell and so, don't shows the value.

If you or someone else could help me on this, I would be thankful!

Wish you a good day and thank you in advnace.

 

[shg]

                If Not rFind Is Nothing Then
                    rFind.Resize(, 2).Copy
                    wksSum.Cells(Rows.Count, "B").End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
                End If

            Next wks

            .Close SaveChanges:=False
        End With

        sFile = Dir()
    Loop
    Application.CutCopyMode = False

 

[Leflex666]

Thank you shg for your quick reply. It helps alot.

Wish you a good day

 

[shg]

You're welcome.