Import data from multiple Excel files from certain cells - excel

Daily I receive 3 Excel files via e-mail and I need file data on one workbook.
The layout of each file is different.
File names will have current date added.
File 1 name is : BlankApp_yyyymmdd.xls
File 2 name is : DisRep_yyyymmdd.xls
File 3 name is : PerApp_yyyymmdd.xls
From File 1, I need data from B2, A7, D11, G11 (Single row)
From File 2, I need data from A7, C8, E9, H9 (Single row), A11, C12, E13, H13 (single row), A15, C16, E17, H17 (single row) & A19, C20, E21, H21 (single row)
From File 3, I need data from B2, A7, D11, G11 (single row)
In summary I need six rows of data on my workbook, which should accumulate on a daily basis.
I found code which gives the outcome I require, but this only resolves part of the question i.e. File1 & File3. Still to find a answer for File2.
Sub BlankandPersonalised()
Const CellList As String = "B2,A7,D11,G11"
Const strFldrPath As String = "C:\New folder\" ' point to the folder where the files reside
Dim wsDest As Worksheet
Dim rngDest As Range
Dim rngCell As Range
Dim arrData() As Variant
Dim CurrentFile As String
Dim rIndex As Long, cIndex As Long
Set wsDest = ActiveWorkbook.ActiveSheet
CurrentFile = Dir(strFldrPath & "*.xls*")
Set rngDest = wsDest.Cells(Rows.Count, "A").End(xlUp).Offset(1)
ReDim arrData(1 To Rows.Count, 1 To Range(CellList).Cells.Count)
Application.ScreenUpdating = False
Do While Len(CurrentFile) > 0
With Workbooks.Open(strFldrPath & CurrentFile)
rIndex = rIndex + 1
cIndex = 0
For Each rngCell In .Sheets(1).Range(CellList).Cells
cIndex = cIndex + 1
arrData(rIndex, cIndex) = rngCell.Value
Next rngCell
.Close False
End With
CurrentFile = Dir
Loop
Application.ScreenUpdating = True
If rIndex > 0 Then rngDest.Resize(rIndex, UBound(arrData, 2)).Value = arrData
Set wsDest = Nothing
Set rngDest = Nothing
Set rngCell = Nothing
Erase arrData
End Sub

Option Explicit
Sub test()
Dim wb As Workbook, wb2 As Workbook, wb3 As Workbook
Dim ws As Worksheet
Dim vFile As Variant
'Set source workbook
Set wb = ActiveWorkbook
'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xls", _
1, "Select One File To Open", , False)
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
'Set targetworkbook
Set wb2 = ActiveWorkbook
'For instance, copy data from a range in the first workbook to another range in the other workbook
wb2.Worksheets("Sheet2").Range("C3:D4").Value = wb.Worksheets("Sheet1").Range("A1:B2").Value
End Sub
Using above should be a good start. Not sure where you want the data or what book you want the macro in.
referenced from here
Copy data from another Workbook through VBA

Here is another example of how to pull all the files in one folder into a workbook.
if you just want to copy the entire sheet in one workbook you can use
Sub add_Sheets()
Dim was As Worksheet
Dim wb As Workbook
Set wb = Application.Workbooks.Open("C:\Location of your files") 'Location of where you want the workbook to be
StrFile = Dir("C:\Location\*.xls") 'Dir of where all the xls are.
Do While Len(StrFile) > 0
Debut.Print StrFile
Application.Workbooks.Open ("C:\Location\" & StrFile)
Set ws = ActiveSheet
ws.UsedRange.Select 'Used range of the worksheet
Selection.Copy
wb.Activate
wb.Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = StrFile
Range("A1").PasteSpecial Paste:=xlPasteValues
StrFile = Dir
Loop
End Sub

Related

find a value in excel across multiple worksheets and workbooks using vba

I have macro that finds the value "a" and replaces with value "b" across multiple worksheets and workbooks
the macro loops through files in folder and files in subfolders and replaces all the values it can find.
now i want the macro to return the file name in column E of the worksheet the macro is written in, ONLY IF changes where made in the file ( so if a was replaced with b return file name in colum E)
but my current code it only returns the file name of the first workbook it runs through.
my codes starts at sub search and it takes as an input sub()
Sub FindReplaceAcrossMultipleExcelWorkbooksFreeMacro(Path As String)
Dim CurrentWorkbookName As String
Dim ExcelCounter As Integer
Dim ExcelWorkbook As Object
Dim FindReplaceCounter As Integer
Dim FindandReplaceWorkbookName As String
Dim FindandReplaceWorksheetName As String
Dim LastRow As Integer
Dim oFile As Object
Dim oFolder As Object
Dim oFSO As Object
Dim Shape As Shape
Dim ws As Worksheet
Dim myrange As Range
Dim look As String
FindandReplaceWorkbookName = ActiveWorkbook.Name
FindandReplaceWorksheetName = ActiveSheet.Name
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(Path)
For Each oFile In oFolder.Files 'Loop through every File in Active Workbook's folder path
If InStr(1, oFile.Type, "Microsoft Excel") <> 0 And InStr(1, oFile.Name, FindandReplaceWorkbookName) = 0 And InStr(1, oFile.Name, "~") = 0 Then 'If the File Type contains the phrase Microsoft Excel isn't the current Excel Workbook and is NOT Lock File
Set ExcelWorkbook = Application.Workbooks.Open(Path & "\" & oFile.Name) 'Open Excel Workbook
CurrentWorkbookName = ActiveWorkbook.Name 'Name of Active Excel Workbook that was opened
Application.Workbooks(CurrentWorkbookName).Activate 'Ensure open Excel Workbook is active for future reference using ActiveWorkbook
Application.ScreenUpdating = False 'Limit screen flashing when Excel Workbooks opened and when Find & Replace is completed
FindReplaceCounter = 2
LastRow = Workbooks(FindandReplaceWorkbookName).Sheets(FindandReplaceWorksheetName).Cells(Rows.Count, 1).End(xlUp).Row 'Identify Last Row in Column A
Do Until FindReplaceCounter > LastRow 'Complete the Find and Replace for all values in Column A & B
For Each ws In ActiveWorkbook.Worksheets 'Loop through every Excel Worksheet in Active Excel Workbook
Set myrange = ws.UsedRange.Find(what:="ben")
If Not myrange Is Nothing Then
Workbooks(FindandReplaceWorkbookName).Sheets(FindandReplaceWorksheetName).Range("E" & Rows.Count).End(xlUp).Offset(1, 0) = ExcelWorkbook.Name
End If
ws.Cells.Replace what:=Workbooks(FindandReplaceWorkbookName).Sheets(FindandReplaceWorksheetName).Cells(FindReplaceCounter, 1).Value, Replacement:=Workbooks(FindandReplaceWorkbookName).Sheets(FindandReplaceWorksheetName).Cells(FindReplaceCounter, 2).Value
Next ws
FindReplaceCounter = FindReplaceCounter + 1
Loop
ActiveWorkbook.Save 'Save Active Excel Workbook
ActiveWorkbook.Close 'Close Active Excel Workbook
End If
Next oFile
Application.ScreenUpdating = True 'Turn Excel ScreenUpdating back on
Set ExcelWorkbook = Nothing
Set oFSO = Nothing
Set oFolder = Nothing
Set oFile = Nothing
Exit Sub
End Sub
Sub Search()
FindReplaceAcrossMultipleExcelWorkbooksFreeMacro (Cells(2, 3).Value)
MsgBox "The Find and Replace has been completed."
End Sub
If I understand you correctly, maybe the code below can help you to compare it with your case.
Sub test()
Dim rg As Range: Dim wb As Workbook
Dim oFSO: Dim oFolder: Dim oFile
Dim fn As String: Dim sh As Worksheet: Dim cell As Range
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
With wb.Sheets("Sheet1")
Set rg = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
.Range("E:E").ClearContents
End With
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder("D:\test")
For Each oFile In oFolder.Files
fn = oFile.Name
If InStr(fn, "test") Then GoTo nextfile:
Workbooks.Open oFile
With ActiveWorkbook
For Each sh In .Worksheets
For Each cell In rg
If Not sh.Cells.Find(cell.Value) Is Nothing Then
sh.UsedRange.Replace what:=cell.Value, Replacement:=cell.Offset(0, 1).Value, LookAt:=xlWhole
wb.Sheets("Sheet1").Range("E" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
fn & " - " & sh.Name & " : value " & cell.Value & " is replaced with " & cell.Offset(0, 1).Value
End If
Next
Next
.Close SaveChanges:=False
End With
nextfile:
Next oFile
Application.ScreenUpdating = True
End Sub
To test the code, create 3 workbooks :
Name the first wb "test.xlsm", this is the wb where the code resides. In test.xlsm sheet Sheet1, make two column header in column A and B, and name it : FIND in A1 and REPLACE in B1. Under FIND, put data such as aaa in A2, bbb in A3, ccc in A4. Under REPLACE, put data such as XXX in B2, YYY in B3, ZZZ in B4.
Create other two workbooks, name it as you like. In each wb, put aaa and/or bbb and/or ccc to whatever cell whatever sheet as many as you like.
put test.xlsm and the other two workbooks in one folder in drive D:, name the folder "test".
Run the code in test.xlsm. Make sure that the other two workbooks is close.
There are three loops in the code.
The first is to loop to each file in test folder
The second is to loop to each sheet of that file
The third is to loop to each FIND/REPLACE value in sheet Sheet1 test.xlsm
On the first loop, it open the file / workbook (which is not test.xlsm)
then it loop to each sheet of that opened wb
on looped sheet, it loop to each data under FIND/REPLACE in sheet1 test.xlsm, and check if the looped cell value is found in the looped sheet, then it perform two process : (A) the found value is replaced with replace value (B) write the information in column E sheet1 of test.xlsm
Please note, the code doesn't write information on the looped sheet of the looped workbook which is being opened. It's just replace to a new value if the value to be replaced is found.
If you run the sub for the second time, there shouldn't be any information in column E sheet Sheet1 in test.xlsm.

In VBA for Excel trying to copy data from one WB to another based on Variable

I am trying to compile data from one large workbook (that will be downloaded once a month) to one that is more concise. I will be pulling in new data every month. I will know the name of the source file and it's location.
Below is the code I am trying to run. It appears to run without errors (going thru all the FOR's and Do Until's) but is just not moving the data from the source file to the destination file. The variable information I am using is column O starting on line 14 of the destination WB. I am trying to sort thru column A of the source WB for some text and the variable from the destination WB. If I have a match I am trying to offset from the matching cell (down 3 rows and right 2 columns) and copy that information to an offset cell on the destination WB (left 4 columns on the same row). Also copying from down 10 rows and right 2 columns on the source to down row 1 and left 4 columns on the destination.
Sub Get_Scorecard()
Dim SourceFile As String
Dim DestFile As String
Dim SourceWB As Workbook
Dim SourceWS As Worksheet
Dim DestWB As Workbook
Dim DestWS As Worksheet
Dim path As String
Dim Msg As String
Dim SCount As Long
Dim sourcestart As Range
Dim TechName As String
'Set starting cell on Dest WS
Range("O14").Activate
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
'Set all the WB's and WS's
path = Application.ThisWorkbook.path & "\"
SourceFile = path & "March Test.xlsx"
DestFile = path & "JobSteps 2019 Test.xlsm"
Set SourceWB = Application.Workbooks.Open(SourceFile)
Set SourceWS = SourceWB.Sheets(1)
Set DestWB = Application.Workbooks.Open(DestFile)
Set DestWS = DestWB.Sheets(1)
'Start in O14 on the Dest WS and loop down till column O is empty
Do Until IsEmpty(ActiveCell.Value)
TechName = ActiveCell.Value
DestStart = ActiveCell.Address
'Start in Cell A2 on the soure WS and search for tech from Dest WS
For SCount = 2 To 700
If SourceWS.Range("A" & SCount).Text = "Provisioning*" & _
TechName & "*" Then
'copy info from 2 offset cells from SourceWS to 2 offset cells on DestWS
'I am offseting 4 columns to left on the DestWS just to see if they appear
DestWS.Range(DestStart).Offset(0, -4).Value = SourceWS.Range(SourceWS.Range _
("A" & SCount).Address).Offset(3, 2).Text
DestWS.Range(DestStart).Offset(-1, -4).Value = SourceWS.Range(SourceWS.Range _
("A" & SCount).Address).Offset(10, 2).Text
End If
Next SCount
'Offset active cell on DestWS by 4 rows
ActiveCell.Offset(4, 0).Activate
Loop
'Close SourceWB
SourceWB.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Range("A1").Activate
End Sub

Changing form range to Columns (a,b,c,d)

I am working on a Macro to extract data from different rows (there are some blank rows) but I want it to search and extract instead of from a range to extract from columns A-D this can be from (A1:D100) then to stop the loop if A(x) where the content of X is "Results". Then to loop to the next workbook.
Sub tgr()
Dim wbDest As Workbook
Dim wsDest As Worksheet
Dim rCopy As Range
Dim sFolder As String
Dim sFile As String
Dim lRow As Long
Set wbDest = ThisWorkbook 'The workbook where information will be copied into
Set wsDest = wbDest.Worksheets("Sheet1") 'The worksheet where information will be copied into
sFolder = "C:\Path\" 'The folder path containing the xlsx files to copy from
'would like sFolder to be the root folder and also
' search for any "*.xlsx" contained inside C:\temp
lRow = 1 'The starting row where information will be copied into
'Adjust the folder path to ensure it ends with \
If Right(sFolder, 1) <> "\" Then sFolder = sFolder & "\"
'Get the first .xlsx file in the folder path
sFile = Dir(sFolder & "*.xlsx")
'Begin loop through each file in the folder
Do While Len(sFile) > 0
'Open the current workbook in the folder
With Workbooks.Open(sFolder & sFile)
'Copy over the formulas from A1:C3 from only the first
' worksheet into the destination worksheet
Set rCopy = .Sheets(1).Range("C9:D26")
wsDest.Cells(lRow, "A").Resize(rCopy.Rows.Count, rCopy.Columns.Count).Formula = rCopy.Formula
'Advance the destination row by the number of rows being copied over
lRow = lRow + rCopy.Rows.Count
.Close False 'Close the workbook that was opened from the folder without saving changes
End With
sFile = Dir 'Advance to the next file
Loop
End Sub
Code 1 is used to find the FIRST occurrence of the string we search for:
Option Explicit
Sub test()
Dim rngSearch As Range, Position As Range
Dim strSearch As String
With ThisWorkbook.Worksheets("Sheet1")
Set rngSearch = .Range("A1:D100") '<- Set the range i want to search in
strSearch = "Test" '<- Set the string i want to search for
Set Position = rngSearch.Find(strSearch) '<- Search for string in range
If Not Position Is Nothing And .Range("A" & Position.Row).Value = "Results" Then '<- Check if string appears in the range and the value in column A and row where the string is "Results"
'Code here
End If
End With
End Sub
Code 2 is used to search the whole range and check ALL occurrence of string we search for:
Option Explicit
Sub test()
Dim rngSearch As Range, cell As Range
Dim strSearch As String
With ThisWorkbook.Worksheets("Sheet1")
Set rngSearch = .Range("A1:D100") '<- Set the range i want to search in
strSearch = "Test" '<- Set the string i want to search for
For Each cell In rngSearch
If cell.Value = strSearch And .Range("A" & cell.Row).Value = "Results" Then
'Code here
End If
Next cell
End With
End Sub

VBA Loop to Delete Multiple Columns

I want to search/loop through all the columns headers located on row 1 of the opened file and delete it if it matches dColumns, which is a list of columns I do not needed and I put in a range.
Sub LLextract()
'Last cell in column
Dim WS As Worksheet
Dim LastCell As Range
Dim LastCellRowNumber As Long
Set WS = ThisWorkbook.Worksheets("Consolidated Data")
With WS
Set LastCell = .Cells(.Rows.Count, "A").End(xlUp)
LastCellRowNumber = LastCell.Row + 0
End With
Dim wb As Workbook, wb2 As Workbook
Dim vFile As Variant
'Set source workbook
Set wb = ActiveWorkbook
'Open the target workbook
vFile = Application.GetOpenFilename("CSV Files (*.csv), *.csv", , _
"Select a CSV file", , False)
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
'Set selectedworkbook
Set wb2 = ActiveWorkbook
Dim dColumns As Range
Set dColumns = wb.Worksheets("LL Columns to Delete").Range("A:A")
Dim i As Integer
Dim A As Range
For i = 94 To 1 Step -1
Set A = wb2.Cells(1, i)
If wb2.Cells(1, i) = dColumns Then A.EntireColumn.Delete
Next i
'wb2.Worksheets(1).Range("A1").Select
End Sub
You can't do just Range("A"), replace that with Range("A:A").
(But what are you trying to do with dColumns?)
I solved it by just deleting the column when I open wb2. This question is no longer need to be answered or solved.

VBA - Copying and Pasting from Multiple Excel files to Single Excel File

Long time reader and admirer of StackOverflow.
Basically I am trying to to loop through a series of Excel files to copy a range of data and paste it on a single Excel workbook/sheet.
The cell range location (C3:D8, D3:E8) is not always consistent, but the table dimensions are: 29 R x 2 C. Also, the files only have 1 sheet, and aside from the table dimensions specified, no data values in other cells.
In its current form the code is executing, but not pasting anything to its destination Excel file.
I need it to
Find the data dimension in file (table)
Copy the table
Paste to destination (below previous table)
Loop through to next file
Repeat Step 1-4
The code is from:
Excel VBA: automating copying ranges from different workbooks into one final destination sheet?
Thanks a lot for any help, I really appreciate it and please feel tell me to specify anything if my question is vague.
Sub SourcetoDest()
Dim wbDest As Workbook
Dim wbSource As Workbook
Dim sDestPath As String
Dim sSourcePath As String
Dim shDest As Worksheet
Dim rDest As Range
Dim vaFiles As Variant
Dim i As Long
'array of folder names under sDestPath
'array of file names under vaFiles
vaFiles = Array("Book1.xls")
sDestPath = "C:\Users"
sSourcePath = "C:\Users"
Set wbDest = Workbooks.Open(sDestPath & "\" & "Book2.xlsm")
Set shDest = wbDest.Sheets(1)
'loop through the files
For i = LBound(vaFiles) To UBound(vaFiles)
'open the source
Set wbSource = Workbooks.Open(sSourcePath & "\" & vaFiles(i))
'find the next cell in col C
Set rDest = shDest.Cells(shDest.Rows.Count, 3).End(xlUp).Offset(1, 0)
'write the values from source into destination
rDest.Resize(5, 1).Value = wbSource.Sheets(1).Range("C7:D33").Value
wbSource.Close False
Next i
End Sub
The below should achieve what you're after.
Option Explicit
Sub copy_rng()
Dim wb As Workbook, wbDest As Workbook, ws As Worksheet, wsDest As Worksheet, wsSrc As Worksheet
Dim wbNames() As Variant
Dim destFirstCell As Range
Dim destColStart As Integer, destRowStart As Long, i As Byte
Dim destPath As String
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1") ' Amend to your sheet name
Set wsSrc = wb.Sheets("Sheet2") ' Amend to sheet name with table data
wbNames = ws.Range("A2:A" & lrow(1, ws)) ' Pass col number into lrow function
destPath = "C:\Users\"
Application.ScreenUpdating = False
For i = 1 To UBound(wbNames, 1)
Set wbDest = Workbooks.Open(destPath & wbNames(i, 1))
Set wsDest = wbDest.Worksheets(1)
With wsDest
Set destFirstCell = .Cells.Find(What:="*")
destColStart = destFirstCell.Column
destRowStart = destFirstCell.Row
.Range(Cells(destRowStart, destColStart), _
Cells(lrow(destColStart, wsDest), icol(destRowStart, wsDest))).Copy
End With
wsSrc.Cells(lrow(1, wsSrc) + 1, 1).PasteSpecial Paste:=xlPasteAll
wbDest.Close False
Next i
Application.ScreenUpdating = True
End Sub
Function lrow(ByVal col_num As Integer, sheet_name As Worksheet) As Long
lrow = sheet_name.Cells(Rows.Count, col_num).End(xlUp).Row
End Function
Function icol(ByVal row_num As Long, sheet_name As Worksheet) As Integer
icol = sheet_name.Cells(row_num, Columns.Count).End(xlToLeft).Column
End Function
Ensure you copy both of the functions across, they're used to create the dimensions of the table, and then copying the table.
You will need to amend the sheet name variables. Let me know if you have any questions.
You need to amend the range of where the workbook names are stored. You need to pass the column number in, so that the last row can be calculated. You can also amend the column in which data is pasted back into the workbook.
With the help of this code you can copy all workbooks and worksheets data
into one workbook
Sub copydata()
Dim fso As Scripting.FileSystemObject
Dim fill As Scripting.File
Dim oldfolder As String
Dim newfolder As String
Dim subfolder As Folder
Dim myfolder As Folder
Dim fd As FileDialog
Dim loopcount As Integer
Dim wb
Dim wb2 As Workbook
Dim rr As Range
Set fso = New Scripting.FileSystemObject
Set wb = ThisWorkbook
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Title = "Please Select Folder to copy"
fd.ButtonName = "Go!"
fd.Show
oldfolder = fd.SelectedItems(1)
Set myfolder = fso.GetFolder(oldfolder)
'Application.ScreenUpdating = False
Application.EnableEvents = False
For Each subfolder In myfolder.SubFolders
For Each fill In subfolder.Files
If fill Like "*.xlsm" Or fill Like "*.xlsx" Or fill Like ".*xls" Then
'fill.Range("A1:Z100").Copy
Set wb2 = Application.Workbooks.Open(fill,0 , True)
wb2.Activate
For loopcount = 1 To wb2.Worksheets.Count
wb2.Activate
Worksheets(loopcount).Activate
Range("A1:Z300").Copy 'Replace your range
wb.Activate
Sheet1.Activate
Set rr = Range("A:A").Find("", Range("A1"))
rr.Select
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Select
Next loopcount
wb2.Close False
End If
Application.CutCopyMode = False
Debug.Print fill.Name
Next fill
Next subfolder
MsgBox "Done"
For Each fill In myfolder.Files
Application.DisplayAlerts = False
If fill Like "*.xlsm" Or fill Like "*.xlsx" Or fill Like ".*xls" Or fill Like "*.xlsb" Then
'fill.Range("A1:Z100").Copy
Set wb2 = Application.Workbooks.Open(fill, 0, True)
wb2.Activate
For loopcount = 1 To wb2.Worksheets.Count
wb2.Activate
Worksheets(loopcount).Activate
Range("A:Z").EntireColumn.Hidden = False
Range("A1:Z1").AutoFilter
Range("A1:Z300").Copy
wb.Activate
Sheet1.Activate
Set rr = Range("A:A").Find("", Range("A1"))
rr.Select
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Select
Next loopcount
wb2.Close False
End If
Application.CutCopyMode = False
Debug.Print fill.Name
Next fill
Application.EnableEvents = True
End Sub

Resources