简体   繁体   中英

VBA Excel copy autosum data to the specified cell

I am trying to sort the exercise, in which the auto summarize data will be copied straight to the cell related from the input-based cell in the row. 在此处输入图像描述

在此处输入图像描述

In the first sheet I have the results of my search across all workbooks in the directory applying the string (code) 4008 in the input.

Next I would like to autosum all these values in the first cell after the last row under E column and paste it directly to the cell, which corresponds to the row, where the code 4008 can be found.

 My code looks like this:

 Sub SearchFolders()

 Dim wbAct As Workbook, pathMainWb As String, fldrPath As String
 Dim bom As String, scrUpdt, WsOut As Worksheet, colFiles As Collection, f As Object
 Dim xBol As Boolean, wb As Workbook, ws As Worksheet, arrWs
 Dim matchedCells As Collection, Cell, numHits As Long, summRow As Long    
 Set wbAct = ActiveWorkbook
 pathMainWb = wbAct.FullName '<<<<

 On Error GoTo ErrHandler

 fldrPath = UserSelectFolder("Select a folder")
If Len(fldrPath) = 0 Then Exit Sub

'get all files in the selected folder
 Set colFiles = GetFileMatches(fldrPath, "*.xls*", False) 'False=no subfolders
 If colFiles.Count = 0 Then
    MsgBox "No Excel files found in selected folder"
    Exit Sub
End If

bom = InputBox("Please provide the Code")

scrUpdt = Application.ScreenUpdating
Application.ScreenUpdating = False

Set WsOut = ThisWorkbook.Worksheets("SUMMARY")

summRow = 1
'sheet names to scan
arrWs = Array("Civils Work Order", "Cable Work Order", "BoM")

WsOut.Cells(summRow, 1).Resize(1, 5).Value = Array("Workbook", "Worksheet", _
                    "Cell", "Text in Cell", "Values corresponding")
For Each f In colFiles
    xBol = (f.Path = pathMainWb)  'file already open?
    If xBol Then
        Set wb = wbAct
    Else
        Set wb = Workbooks.Open(Filename:=f.Path, UpdateLinks:=0, _
                                 ReadOnly:=True, AddToMRU:=False)
    End If
    
    For Each ws In wb.Worksheets
        'are we interested in this sheet?
        If Not IsError(Application.Match(ws.Name, arrWs, 0)) Then
            Set matchedCells = FindAll(ws.UsedRange, bom) 'get all cells with bom
            If matchedCells.Count > 0 Then
                For Each Cell In matchedCells
                    summRow = summRow + 1
                    WsOut.Cells(summRow, 1).Resize(1, 5).Value = _
                        Array(wb.Name, ws.Name, Cell.Address, Cell.Value, _
                                Cell.EntireRow.Range("F1").Value)
                
                    numHits = numHits + 1
                Next Cell     'next match
            End If            'any bom matches
        End If                'matched sheet name
    Next ws
    If Not xBol Then wb.Close False 'need to close this workbook?
Next f

With WsOut
Dim lastRow As Long
.Columns("A:E").EntireColumn.AutoFit
lastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
.Range("E" & lastRow + 1).Value = WorksheetFunction.Sum(Range("E2:E" & lastRow + 1))

ThisWorkbook.Worksheets("Test").Range("I1").Value = .Range("E" & lastRow + 1).Value

 For i = 2 To Excel.WorksheetFunction.CountA(Range("A:A"))
 If Range("A" & i).Value = bom Then
      Range("F" & i).Value = WsOut.Range("E" & lastRow + 1).Value
 End If
 Next i
End With

    
MsgBox numHits & " cells have been found", , "Calculator"

ExitHandler:
Application.ScreenUpdating = scrUpdt
Exit Sub

ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler

End Sub

The first question is:

  1. Why the autosum cannot work when outside of ActiveSheet ? (following this thread Can't copy value from the Last Row to other worksheet )
  2. How could I provide the summed value to the cell I want. When applying this solution: Formula to search rows for certain value and get corresponding cells the Msgbox throws the current value under the cell pointed out in the second image. When I appy the autosum from other sheet it shows "false"?

Is there a chance to make this value copied directly to the cell appropriat for the given code applied?

When you're using application functions or things like that, even while using With WsOut... End With you need to keep using the indirect reference (I don't know the correct terminology) with .Range instead of the normal Range

Sub testSum()
    Dim wb As Workbook: Set wb = Workbooks("MOSTEST.xlsx")
    Dim ws As Worksheet: Set ws = wb.Sheets("Testsheet")
    
    ws.Range("C39").Value = WorksheetFunction.Sum(ws.Range("C29:C38")) 'Not just Range()
    MsgBox ("The sum is = " & ws.Range("C39").Value)
    ws.Range("C39").Clear
    
    With ws
        .Range("C39").Value = WorksheetFunction.Sum(.Range("C29:C38")) 'Not just Range()
        MsgBox ("The sum is = " & .Range("C39").Value)
    End With
End Sub

Both of these work just fine even if the workbook isn't active.

So in your case if you change

.Range("E" & lastRow + 1).Value = WorksheetFunction.Sum(Range("E2:E" & lastRow + 1))
'into 
.Range("E" & lastRow + 1).Value = WorksheetFunction.Sum(.Range("E2:E" & lastRow + 1))

it should work as intended:)

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM