copying different excel files rows in one folder with similar A1 cell into one master file via vba (code not working) - vba

Question

Unfortunately I'm not much of a VBA expert, however I have managed to gather these codes from different websites.
I'm trying to get an Automation System running in excel and currently I'm able to send specific rows from an Excel sheet as attachment to each email mentioned in that row. Using this code:
Sub Send_Row_direct()
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim NewWB As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = ActiveSheet
'Set filter range and filter column (column with e-mail addresses)
Set FilterRange = Ash.Range("A1:AF" & Ash.Rows.Count)
FieldNum = 2 'Filter column = B because the filter range start in column A
'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=False
'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))
'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount
'If the unique value is a mail addres create a mail
If Cws.Cells(Rnum, 1).Value Like "?*#?*.?*" Then
'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value
'Copy the visible data in a new workbook
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
Set NewWB = Workbooks.Add(xlWBATWorksheet)
rng.Copy
With NewWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With
'Create a file name
TempFilePath = Environ$("temp") & "\"
TempFileName = "KBB_taskforce_assignment_on_" _
& " " & Format(Now, "dd-mmm-yy h-mm-ss")
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
FileExtStr = ".xlsx": FileFormatNum = 51
End If
'Save, Mail, Close and Delete the file
Set OutMail = OutApp.CreateItem(0)
With NewWB
.SaveAs TempFilePath & TempFileName _
& FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = Cws.Cells(Rnum, 1).Value
.Subject = Range("F2")
.Attachments.Add NewWB.FullName
.Body = Range("G2")
.send 'Or use Send
End With
On Error GoTo 0
.Close savechanges:=False
End With
Set OutMail = Nothing
Kill TempFilePath & TempFileName & FileExtStr
End If
'Close AutoFilter
Ash.AutoFilterMode = False
Next Rnum
End If
cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True
With Application
.EnableEvents = True
.ScreenUpdating = True
End With End Sub
Lets say the emails come back with the attachments and I have saved them all in one Folder.
Now I need a VBA code to read through these attachments, which all are stored in a folder, and show the rows which have similar values in cell A2.
The current code that I have managed to setup does the job perfectly with any other Excel file. But when it starts processing the auto made files by my VBA code it runs into Error 91. The line which the error is at is CopyRange.Select
and when removing it I will get another error at CopyRange.Copy MasterSht.Cells(MasterWBShtLstRw + 1, 1) and when removing this line I will get no rows copied into my master file.
The Code is below :
Option Explicit Sub CopyToMasterFile11()
Dim MasterWB As Workbook
Dim MasterSht As Worksheet
Dim MasterWBShtLstRw As Long
Dim FolderPath As String
Dim TempFile
Dim CurrentWB As Workbook
Dim CurrentWBSht As Worksheet
Dim CurrentShtLstRw As Long
Dim CurrentShtRowRef As Long
Dim CopyRange As Range
Dim ProjectNumber As String
FolderPath = "d:\test\"
TempFile = Dir(FolderPath)
Dim WkBk As Workbook
Dim WkBkIsOpen As Boolean
'Check is master is open already
For Each WkBk In Workbooks
If WkBk.Name = "master.xlsm" Then WkBkIsOpen = True
Next WkBk
If WkBkIsOpen Then
Set MasterWB = Workbooks("master.xlsm")
Set MasterSht = MasterWB.Sheets("here")
Else
Set MasterWB = Workbooks.Open(FolderPath & "master.xlsm")
Set MasterSht = MasterWB.Sheets("here")
End If
ProjectNumber = MasterSht.Cells(1, 1).Value
Do While Len(TempFile) > 0
'Checking that the file is not the master and that it is a xlsx
If Not TempFile = "master.xlsm" And InStr(1, TempFile, "xlsx", vbTextCompare) Then
Set CopyRange = Nothing
'Note this is the last used Row, next empty row will be this plus 1
With MasterSht
MasterWBShtLstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Set CurrentWB = Workbooks.Open(FolderPath & TempFile)
Set CurrentWBSht = CurrentWB.Sheets("Tabelle1")
With CurrentWBSht
CurrentShtLstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For CurrentShtRowRef = 1 To CurrentShtLstRw
' If CurrentWBSht.Cells(CurrentShtRowRef, "A").Value = ProjectNumber Then
'This is set to copy from Column A to Column L as per the question
If CopyRange Is Nothing Then
'If there is nothing in Copy range then union wont work
'so first row of the work sheet needs to set the initial copyrange
Set CopyRange = CurrentWBSht.Range("A" & CurrentShtRowRef & _
":AF" & CurrentShtRowRef)
Else
'Union is quicker to be able to copy from the sheet once
Set CopyRange = Union(CopyRange, CurrentWBSht.Range("A" & CurrentShtRowRef & ":AF" & CurrentShtRowRef))
End If ' ending If CopyRange Is Nothing ....
' End If ' ending If CurrentWBSht.Cells....
Next CurrentShtRowRef
CopyRange.Select
'add 1 to the master file last row to be the next open row
CopyRange.Copy MasterSht.Cells(MasterWBShtLstRw + 1, 1)
CurrentWB.Close savechanges:=False
End If 'ending If Not TempFile = "zmaster.xlsx" And ....
TempFile = Dir
Loop
End Sub
I hope I was able to explain my self properly. I would highly appreciate any productive solution.