Modifying Ron's codes (Again...)

[Robin]

Hello everyone

i need some help to modify the code below. what the code does is create a
sheet called "Summary" where all values from the workbooks is copied.

the thing is that i want the macro to cut the data from an already existing
"Summary" sheet and paste it into another sheet called "BackUp", and then
merge all the data from the different workbooks into an existing "Summary"
sheet.

i am new to coding macros so any help here would be very much appriciated

Option Explicit


Sub MergeMacro()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long, FNum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
Dim rng As Range, SearchValue As String
Dim FilterField As Integer, RangeAddress As String
Dim ShName As Variant, RwCount As Long
Dim FolderRowCount As Long
'**********************************************************
'***Change this five code lines before you run the macro***
'**********************************************************


'Fill in the sheet name where the data is in each workbook
'Use ShName = "Sheet1" if you want to use a sheet name instead if the
Index
'We use the first sheet in every workbook in this example(I use the index)
ShName = 1

'Fill in the filter range: A1 is the header of the first column and G is
'the last column in the range and it will filter on all rows on the sheet
'You can also use a fixed range like A1:G2500 if you want
RangeAddress = Range("A1:IV" & Rows.Count).Address

'Field that you want to filter in the range ( 1 = column A in this
'example because the filter range start in column A
FilterField = 1

'Fill in the filter value ("<>ron" if you want the opposite)
'Or use wildcards like "*ron" for cells that start with ron or use
'"*ron*" if you look for cells where ron is a part of the cell value
SearchValue = "<>~!@#$%^&*()_+"

'**********************************************************
'**********************************************************

'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

'create new sheet for summary
With ThisWorkbook
Set BaseWks = .Sheets.Add(after:=.Sheets(.Sheets.Count))
BaseWks.Name = "Summary"
'set row number of summary to 1
rnum = 1
End With

With ThisWorkbook.Sheets("Folder sheet")

FolderRowCount = 1
Do While .Range("A" & FolderRowCount) <> ""
MyPath = .Range("A" & FolderRowCount)
'Add a slash after MyPath if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder go to next folder
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
Else

'Fill the array(myFiles)with the list of Excel files in the
folder
FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop



'Loop through all files in the array(myFiles)
If FNum > 0 Then
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0

If Not mybook Is Nothing Then

On Error Resume Next
'set filter range
With mybook.Worksheets(ShName)
Set sourceRange = .Range(RangeAddress)
End With

If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
End If
On Error GoTo 0

If Not sourceRange Is Nothing Then
If FNum = 1 Then
mybook.Worksheets(ShName).Range("A1:Z1").Copy _
BaseWks.Range("B1")
End If

'Find the last row in BaseWks
rnum = RDB_Last(1, BaseWks.Cells) + 1

With sourceRange.Parent
Set rng = Nothing

'Firstly, remove the AutoFilter
.AutoFilterMode = False

'Filter the range on the FilterField column
sourceRange.AutoFilter Field:=FilterField, _
Criteria1:=SearchValue

With .AutoFilter.Range

'Check if there are results after you use
AutoFilter
RwCount = .Columns(1).Cells. _
SpecialCells(xlCellTypeVisible).Cells.Count - 1

If RwCount = 0 Then
'There is no data, only the header
Else
' Set a range without the Header row
Set rng = .Resize(.Rows.Count - 1,
..Columns.Count). _
Offset(1,
0).SpecialCells(xlCellTypeVisible)


'Copy the range and the file name in column A
If rnum + RwCount < BaseWks.Rows.Count Then
BaseWks.Cells(rnum,
"A").Resize(RwCount).Value _
= mybook.Name
rng.Copy BaseWks.Cells(rnum, "B")
End If
End If

End With

'Remove the AutoFilter
.AutoFilterMode = False

End With
End If

'Close the workbook without saving
mybook.Close savechanges:=False
End If

'Open the next workbook
Next FNum

'Set the column width in the new workbook
BaseWks.Columns.AutoFit
MsgBox "Look at the merge results in the new " & _
"workbook after you click on OK"
End If
End If

FolderRowCount = FolderRowCount + 1
Loop
End With

'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
Function RDB_Last(choice As Integer, rng As Range)
'Ron de Bruin, 5 May 2008
' 1 = last row
' 2 = last column
' 3 = last cell
Dim lrw As Long
Dim lcol As Integer

Select Case choice

Case 1:
On Error Resume Next
RDB_Last = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0

Case 2:
On Error Resume Next
RDB_Last = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0

Case 3:
On Error Resume Next
lrw = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0

On Error Resume Next
lcol = rng.Find(What:="*", _
after:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0

On Error Resume Next
RDB_Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
If Err.Number > 0 Then
RDB_Last = rng.Cells(1).Address(False, False)
Err.Clear
End If
On Error GoTo 0

End Select
End Function

 

[Ron de Bruin]

Hi Robin

I try to read and reply tomorrow with a example

 

[Ron de Bruin]

Do you want to keep one backup sheet or more ?

If you want more maybe add a date to the worksheet name so you know which date you merge the data in that sheet ?

Do I understand you correct that you have a empty (only headers) Summary sheet that you want to use
each time when you run the macro ?

 

[Robin]

Hi Ron!

well let me make it easier(i found it confusing too when i re-read it =P)

the Summary sheet has headers and some formulas.
and for the back up sheets, is it possiable to create a new sheet as back up
for all the previous data in summary, but each of the new sheet's name is the
date and time the macro was run.

i am sorry for being so confusing -.-"

hopefuly u can help me

Thanks and Regards
Robin

 

[Ron de Bruin]

I post a example this evening

 

[Ron de Bruin]

I think this is a good and easy option for you

Add a worksheet named "template" in the workbook with the headers and formulas
When you run the code it will make a copy of it and name it with the date/time

Everytime you run the macro it will create a new sheet with the data for you so you have al your backups

With ThisWorkbook
.Worksheets("template").Copy after:=.Sheets(.Sheets.Count)
Set BaseWks = ActiveSheet
BaseWks.Name = Format(Now, "yyyy-mmm-dd hh-mm-ss")
End With

 

[Robin]

hey thx for the code, but i just have a tiny bit of problem, i dun noe where
to put the lines of code u provided -.-"
hope u can help me again.

Thanks and Regards
Robin

 

[Robin]

hey its fine, i managed to figure out where the code goes =P
and the code work brilliantly :-D

thank u Ron, once again u save the day ;-)

Thanks and Regards
Robin