VBA code to combine two Workbooks into one Worksheet - excel

I want to know if it is possible to bring two workbooks (sheet1) into one worksheet (master workbook). I need to have two data together in one worksheet.
Any help is really appreciated. Below are screenshots for further details if helps.
Two files:
Fundraise-pages(1).csv
Supporters(1).csv
Please see the attached for further details if help?
Thank you for looking into this.
File 1 and File 2 data - both have the same email addresses.
Importantly I would like a macro to pull data to identify or even match for both email addresses. If found then add it onto a worksheet.
For example on the worksheet (master) there should be a data file 1 on the left hand side and the data file 2 on the right hand side including headings.
I hope you can see my images clearly?
Regards
V
enter image description here
enter image description here

Here is an overview to start with:
https://support.microsoft.com/en-us/office/import-or-export-text-txt-or-csv-files-5250ac4c-663c-47ce-937b-339e391393ba
Vba Import CSV files to Excel
Proposal:
Using the connection via PowerQuery allows you to further process them as tables and also join/merge them into one while you can see and follow each step of the process.

Something like this should do what you want. Feel free to change the code to suit your needs.
Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the sheet "RDBMergeSheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
'Find the last row with data on the DestSh
Last = LastRow(DestSh)
'Fill in the range that you want to copy
Set CopyRng = sh.Range("A1:G1")
'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
'This example copies values/formats, if you only want to copy the
'values or want to copy everything look at the example below this macro
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
'Optional: This will copy the sheet name in the H column
DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Source code:
https://www.rondebruin.nl/win/s3/win002.htm
Also, check this out.
https://www.rondebruin.nl/win/addins/rdbmerge.htm

Related

Values not capture properly

I have a question related to the VBA.
Problem
I have a code to do simple task but i don't what's the reason but sometimes this code works perfectly some time it's not.
Code Explanation
Go to active sheets(un-hidden) sheets in the work book.
Search specific text in the assign column, in this case text is "Sum of Current Activity".
Copy the cell before the text.
Go to Reviewer sheet and find sheet name in the table.
Paste the copied cell as link value next to cell where we have sheet name in the table.
Continue the same process until all active sheets searched
CODE
Sub Sum of_Current_activity()
Dim sht As Worksheet
Sheets("Reviewer Sheet").Select
For Each sht In ActiveWorkbook.Worksheets
If sht.Name <> "Reviewer Sheet" And Left(sht.Name, 1) = 0 Then
On Error Resume Next
sht.Select
f2 = " Total"
£1 = ActiveSheet.Name & f2
Sheets(sht).Select
Columns("J:J").Select
Selection.Find(What:="Sum of Current Activity", _
After:=ActiveCell,_
LookIn:=xlValues,_
LookAt:=xlPart,_
SearchOrder:=xlByRows,_
SearchDirection:=x1Next,_
MatchCase:=False).Activate
ActiveCell.Offset(0, 1).Select
Selection.Copy
Sheets("Reviewer Sheet").Select
Columns("C:C").Select
Selection.Find(What:=f1, _
After:=ActiveCell,_
LookIn:=xlValues,_
LookAt:=xlPart,_
SearchOrder:=xlByRows,_
SearchDirection:=xlNext,_
MatchCase:=False).Activate
ActiveCell.Offset(0, 14).Select
ActiveSheet. Paste Link:=True
Else
End If
Next sht
End Sub
P.S, I have 10 different specific text to search in the 25 sheet. this code sometime works for all 10 texts and sometimes miss the values.
Untested but something like this should work:
Sub Sum of_Current_activity()
Dim sht As Worksheet, c1 As Range, c2 As range
For Each sht In ActiveWorkbook.Worksheets
If sht.Name Like "0*" Then
Set c1 = sht.Columns("J:J").Find(What:="Sum of Current Activity", _
LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
Set c2 = Sheets("Reviewer Sheet").Columns("C:C").Find( _
What:= sht.Name & " Total", _
LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
If not c1 is nothing and not c2 is nothing then
'edit: create link instead of copy value
c2.offset(0, 14).Formula = _
"='" & c1.parent.Name & "'!" & c1.offset(0,1).Address(true, true)
End if
End If
Next sht
End Sub
just because the task is simple, you could use On Error Resume Next statement and make a direct Value paste between ranges:
Sub main()
Dim sht As Worksheet
On Error Resume Next ' prevent any subsequent 'Find()' method failure fro stopping the code
For Each sht In Worksheets
If Left(sht.Name, 1) = "0" Then _
Sheets("Reviewer Sheet").Columns("C:C").Find( _
What:=sht.Name & " Total", _
LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False).Offset(0, 14).Value = sht.Columns("J:J").Find(What:="Sum of Current Activity", _
LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False).Offset(0, 1).Value
Next
End Sub
I once more stress that On Error Resume Next is here used only because it's a case where you can have a full control of its side effects that can arise from ignoring errors and go on
should you use this snippet in a bigger code, than close the snippet with On Error GoTo 0 statement and resume default error handling before going on with some other code.

VBA code has too many loops which makes it run slower

I have a VBA code which copies same data from Multiple sheet and then paste it in "Main" Sheet. It then auto fills the blank cells for values from above and then it delete all the rows Where H:H is blank. However being novice in VBA, i feel my code has too many loops, which makes it run slower. Moreover if have the "Main" Sheet have a table formatted, the code does not delete any row H is blank. However it works if "Main" is blank and not formatted.
Another thing I found out that after the code is executed, the excel sheet becomes less responsive. I cannot select cells quickly, change between sheets.
Please advise if anything can be improved to make it run more efficiently.
Private Sub CopyRangeFromMultiWorksheets1()
'Fill in the range that you want to copy
'Set CopyRng = sh.Range("A1:G1")
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim rng As Range
Dim Last As Long
Dim CopyRng1 As Range
Dim CopyRng2 As Range
Dim CopyRng3 As Range
Dim CopyRng4 As Range
Dim CopyRng5 As Range
Dim CopyRng6 As Range
Dim CopyRng7 As Range
Dim cell As Range
Dim Row As Range
Dim LastrowDelete As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the sheet "RDBMergeSheet" if it exist
'Application.DisplayAlerts = False
On Error Resume Next
'ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
'Application.DisplayAlerts = True
'Add a worksheet with the name "RDBMergeSheet"
Set DestSh = Sheets("Main")
'Set DestSh = ActiveWorkbook.Worksheets.Add
' DestSh.Name = "RDBMergeSheet"
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name And sh.Name <> "PAYPERIOD" And sh.Name <>
"TECHTeamList" Then
'Find the last row with data on the DestSh
Last = LastRow(DestSh)
'Fill in the range that you want to copy
Set CopyRng1 = sh.Range("B3")
Set CopyRng2 = sh.Range("C3")
Set CopyRng3 = sh.Range("D3")
Set CopyRng4 = sh.Range("G3")
Set CopyRng5 = sh.Range("C5")
Set CopyRng6 = sh.Range("A8:j25")
Set CopyRng7 = sh.Range("A28:j45")
'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng1.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
'This example copies values/formats, if you only want to copy the
'values or want to copy everything look at the example below this
macro
CopyRng1.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
CopyRng2.Copy
With DestSh.Cells(Last + 1, "B")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
CopyRng3.Copy
With DestSh.Cells(Last + 1, "C")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
CopyRng4.Copy
With DestSh.Cells(Last + 1, "D")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
CopyRng5.Copy
With DestSh.Cells(Last + 1, "E")
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With
CopyRng6.Copy
With DestSh.Cells(Last + 1, "F")
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End With
'Refresh the Lastrow used so that the values start from
'underneath copyrng6
Last = LastRow(DestSh)
CopyRng7.Copy
With DestSh.Cells(Last + 1, "F")
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End With
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
'Autofill the rang A2:E for values from above looking at the last row of F
With Range("A2:E" & Range("F" & Rows.Count).End(xlUp).Row)
.SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
'Delete Entire rows where H is Blank
Application.ScreenUpdating = False
Columns("H:H").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Any Help would be appreciated.

Copy data from dynamically named source file into master file

I have a Master workbook (Consolidate Tracker) where we add data from Source file.
Consolidated Tracker and Source file have three tabs (Open Positions, Closed, Cancelled).
Every week I put data from Source file (from each tab) into the Consolidated file (to each tab).
For example: Open Positions data from Source file goes to Open Positions in Consolidated Tracker and so on.
I am facing the following issues:
I have to give full name of the files.
For example. Workbooks("Source*") is not working.
Is there a way to give only partial names?
My file name will have a date in the end. Hence I want to give *.
ActiveWorkbook.Sheets(I) or ActiveWorkbook.Sheets("Name") always goes for the Open Worksheet/Tab.
Pasting the output gives the following error.
Method PasteSpecial of Object Range Failed
Selection.EntireRow.Delete sometimes gives error or sometimes
doesn’t delete and again goes into For loop.
Also, it seems the loop is not taking the next tab.
Sub GetSheets()
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("D:\2018\ VBA\Consolidated Tracker.xlsm")
Workbooks("Source_Tracker.xlsx").Activate
For I = 1 To 3
Set Sheet = ActiveWorkbook.Sheets(I)
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
Range("A1").Select
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
With Range("A1:A" & LastRow)
.Value = Date
.NumberFormat = "mm/dd/yy"
End With
Range("A1").Select
ActiveCell.Offset(1, 0).Select
Selection.CurrentRegion.Copy
Workbooks("Consolidated Tracker").Activate
Set Sheet = Workbooks("Consolidated Tracker.xlsm").Sheets(I)
Range("A100000").Select
Selection.End(xlUp).Select
ActiveCell.Offset(1, 0).Select
ActiveCell.PasteSpecial
ActiveCell.Offset(0, 0).Select
Selection.EntireRow.Delete
Next I
End Sub
Consider this rewrite.
Option Explicit
Sub GetSheets()
Dim i As Long, lr As Long
Dim wb1 As Workbook, wb1 As Workbook
Application.Workbooks.Open Filename:="D:\2018\ VBA\Consolidated Tracker.xlsm", _
ReadOnly:=True, AddToMru:=False
setWbs wb1, wb2
With wb1
For i = 1 To 3
With .Worksheets(i)
.Columns("A:A").Insert Shift:=xlToRight
lr = Cells.Find(what:="*", after:=.Cells(1), _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
With .Range(.Cells(1, "A"), .Cells(lr, "A"))
.Value = Date
.NumberFormat = "mm/dd/yy"
End With
.Cells(1, "A").CurrentRegion.offset(1, 0).Copy _
Destination:=wb2.Worksheets(i).Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
End With
Next i
End With
End Sub
Sub setWbs(ByRef wkbk1 As Workbook, ByRef wkbk2 As Workbook)
Dim wb As Long
For wb = 1 To application.Workbooks.Count
Select Case left(LCase(Workbooks(wb).name), 7)
Case "source_"
Set wkbk1 = Workbooks(wb)
Case "consoli"
Set wkbk2 = Workbooks(wb)
End Select
Next wb
End Sub

Merging sheets in to a master sheet

I got the following code from Ron de Bruin's site and it works pretty much fine for pulling data into a master sheet, and updating the master sheet whenever there are changes in the other sheets.
But I would like to copy only certain columns of data. For example my sheets have data from A:Z but i only need the A:P data in my master sheet.
Any help on this will be greatly appreciated and please know that im a non-coder, so please be specific about what to change and where to change it.
Sub CopyDataWithoutHeaders()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Delete the sheet "Master Sheet" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Master Sheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Add a worksheet with the name "Master Sheet"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Master Sheet"
'Fill in the start row
StartRow = 2
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
'Copy header row, change the range if you use more columns
If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then
sh.Range("A1:Z1").Copy DestSh.Range("A1")
End If
'Find the last row with data on the DestSh and sh
Last = LastRow(DestSh)
shLast = LastRow(sh)
'If sh is not empty and if the last row >= StartRow copy the CopyRng
If shLast > 0 And shLast >= StartRow Then
'Set the range that you want to copy
Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
'Test if there enough rows in the DestSh to copy all the data
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the Destsh"
GoTo ExitTheSub
End If
'This example copies values/formats, if you only want to copy the
'values or want to copy everything look below example 1 on this page
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Actually you just have to change the code that defines the area that should be copied. In your case you have to check the "ranges" before copying the data:
sh.Range("A1:Z1").Copy DestSh.Range("A1")
That line takes care of the headlines, so you can replace the Z1 with e. g. P1.
The next range is to copy the data:
Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
Here you can use the existing functionality to get the correct start row and last row. But instead of selecting the complete rows you will just select a part of the sheet:
sh.Range("A" & StartRow & ":P" & shLast)
That should do the trick.
P. S. Even If you are not a programmer. Have a look at the VBA Basics, its not that hard and you can do a lot of cool stuff if you know how it works... :)

Combine/Append multiple data worksheets into one summary worksheet and then delete data worksheets

In my workbook I have a FrontPage sheet with a button. This button imports csv files. Each csv file is imported/copied to its own sheet (let's call them data sheets). This part is complete. In the second part I want to combine all these sheets into one summary sheet and then delete all the data sheets. The second part is almost completed. I only need to figure out how to delete the data sheets once they have been combined into the summary sheet.
Thanks!
This is the code so far:
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Sub CopyDataWithoutHeaders()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"
StartRow = 2
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
Last = LastRow(DestSh)
shLast = LastRow(sh)
If shLast > 0 And shLast >= StartRow Then
Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
MsgBox "There are not enough rows in the " & _
"summary worksheet to place the data."
GoTo ExitTheSub
End If
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
End If
Next
ExitTheSub:
Application.Goto DestSh.Cells(1)
DestSh.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
If you give the sheets convenient names, you can simply loop through all the sheets and delete those called Data[something] for example.
For i = 1 To ActiveWorkbook.Worksheets.Count
If Left(Worksheets(i).Name, 4) = "Data" Then
Application.DisplayAlerts = False
Worksheets(i).Delete
Application.DisplayAlerts = True
End If
Next
Looks like you already have 3/4 of the code (the loop, and name check) going on.
After copying what you need to copy, just add:
Application.DisplayAlerts = False
sh.Delete
Application.DisplayAlerts = True
This deletes the worksheet and removes the requirement for the user to accept / decline the deletion.
Looks like this would go immediately after this block:
CopyRng.Copy
With DestSh.Cells(Last + 1, "A")
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With

Resources