I am attempting to consolidate data from multiple workbooks into one Master workbook. All workbooks, including the master workbook, have the same worksheets. The data in the worksheets, however, is different. Each workbook is created from asking the same survey questions. I am looking to consolidate all survey answers into one workbook.
Code:
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim lastRowNumber As Double
Dim lastColumnNumber As Double
Dim theLastCell As String
Dim copyRange As Range
Dim pasteRange As Range
Dim sheetName As String
Dim copyRangeString As String
Dim pasteRangeString As String
Do While myFile <> ""
Set wb = Workbooks.Open(FileName:=myPath & myFile)
DoEvents
wb.Worksheets(1).Range("A2:D2").Interior.color = RGB(51, 98, 174)
For i = 1 To 8
lastRowNumber = lastRowUsed(wb.Sheets(i))
lastColumnNumber = wb.Sheets(i).Range("A1").SpecialCells(xlCellTypeLastCell).Column
theLastCell = Cells(lastRowNumber, lastColumnNumber).Address(RowAbsolute:=False, ColumnAbsolute:=False)
Set copyRange = wb.Worksheets(i).Range("A2:" & theLastCell)
copyRangeString = "A2:" & theLastCell
lastRowNumber = lastRowUsed(theWorkbook.Sheets(i)) + lastRowUsed(wb.Sheets(i))
pasteRangeString = "A" & lastRowNumber & ":" & theLastCell
theWorkbook.Sheets(i).Range(pasteRangeString) = wb.Sheets(i).Range(copyRangeString).value
copyRangeString = ""
pasteRangeString = ""
sheetName = wb.Sheets(i).name
MsgBox sheetName
Next
wb.Close
DoEvents
myFile = dir
Loop
I am trying to accomplish this by looping through each Excel file in a folder, looping through (1-8) of the worksheets. Creating a range of the data in each worksheet, and then copying and pasting into the theWorkbook "master" workbook. For whatever reason, only data from the last workbook in the folder is getting copied.
Any and all help is much appreciated!
Related
I have a little problem with my code. I want to copy my data from one file to my main file. When I check the code I meet with one problem. The code works fine until copied. In this line
Set cell1 = wsDest.Cells(1, Range("B1").End(xlToRight).Column + 1)
the cell is selected from the file from I am taking the data and not the folder I am pasting into.
I want my data to paste from these other files into the main file. I want to add them as columns, not rows.
Sub MoveCopyRowsColumns()
Dim mainWb As Workbook
Dim newWb As Workbook
Dim mainWs As Worksheet
Dim newWs As Worksheet
Dim strFolder As String
Set mainWb = Workbooks("Main_file.xlsm")
Set mainWs = mainWb.Worksheets("Worksheet1")
mainWs.Cells(1, Range("B1").End(xlToRight).Column + 1).Select
mainWs.Columns(ActiveCell.Column).EntireColumn.Delete
strFolder = "C:\Users\User1\Desktop\Folder_with_files\"
strFile = Dir(strFolder & "*.xls*")
Do While strFile <> ""
Set newWb = Workbooks.Open(strFolder & strFile)
Set newWs = newWb.Sheets(1)
strFile = Dir
newWs.Cells(1, Range("B1").End(xlToRight).Column + 1).Select
newWs.Columns(ActiveCell.Column).EntireColumn.Delete
newWs.Range("B1", Range("B1").End(xlDown).End(xlToRight)).Copy _
mainWs.Range("P1")
Loop
End Sub
You have to declare which file/sheet is which. Each line should refer to the right worksheet. All lines starting with cell or range should have worksheet first like: "mainWs.Cell".
In the new file you have not declared any worksheet, only workbook (wb).
I haven't tryed the code below, but I hope it unlocks your problem thinking.
Good luck!
Sub MoveCopyRowsColumns()
Dim mainWb As Workbook
Dim newWb As Workbook
Dim mainWs As Worksheet
Dim newWs As Worksheet
Dim strFolder As String
Dim strFile As String
Dim cell1 As Range
Set mainWb = Workbooks("Main_file.xlsm")
Set mainWs = mainWb.Worksheets("Worksheet1")
mainWs.Cells(1, Range("B1").End(xlToRight).Column + 1).Select
mainWs.Columns(ActiveCell.Column).EntireColumn.Delete
'in my main file I delete the last column only one
strFolder = "C:\Users\User1\Desktop\Folder_with_files\"
strFile = Dir(strFolder & "*.xls*")
Do While strFile <> ""
Set newWb = Workbooks.Open(strFolder & strFile)
'Set the sheet you want to use, using "first sheet" or sheet by name
'Set newWs = newWb.Sheets(1)
'Set newWs = newWb.Worksheets("Worksheet1")
strFile = Dir
newWs.Cells(1, Range("B1").End(xlToRight).Column + 1).Select
newWs.Columns(ActiveCell.Column).EntireColumn.Delete
'Set cell1 = newWs.Cells(1, Range("B1").End(xlToRight).Column + 1)
newWs.Cells(1, Range("B1").End(xlToRight).Column + 1).Copy
'the adress is taking from file when I take the data, not the main file which should take.
mainWs.Range(cell1).PasteSpecial Paste:=xlPasteValues
Loop
End Sub
I have multiple workbooks in a single folder. All the workbooks share the same format and I wish to copy from the same range on the first worksheet in all workbooks and add this to a single worksheet of a newly created workbook.
The code so far:
Sub OpenAllCompletedFilesDirectory()
Dim Folder As String, FileName As String
Folder = "pathway..."
FileName = Dir(Folder & "\*.xlsx")
Do
Dim currentWB As Workbook
Set currentWB = Workbooks.Open(Folder & "\" & FileName)
CopyDataToTotalsWorkbook currentWB
FileName = Dir
Loop Until FileName = ""
End Sub
Sub AddWorkbook()
Dim TotalsWorkbook As Workbook
Set TotalsWorkbook = Workbooks.Add
outWorkbook.Sheets("Sheet1").Name = "Totals"
outWorkbook.SaveAs FileName:="pathway..."
End Sub
Sub CopyDataToTotalsWorkbook(argWB As Workbook)
Dim wsDest As Worksheet
Dim lDestLastRow As Long
Dim TotalsBook As Workbook
Set TotalsBook = Workbooks.Open("pathway...")
Set wsDest = TotalsBook.Worksheets("Totals")
Application.DisplayAlerts = False
lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Row
argWB.Worksheets("Weekly Totals").Range("A2:M6").Copy
wsDest.Range("A" & lDestLastRow).PasteSpecial
Application.DisplayAlerts = True
TotalsBook.Save
End Sub
This works - to a point. It does copy the correct ranges across and place the results one below another on the "Totals" worksheet of the "Totals" workbook, but it raises a 'Subscript out of range' error on:
argWB.Worksheets("Weekly Totals").Range("A2:M6").Copy
after data from the last workbook has been pasted.
How can I tidy this code so that it works without error?
I imagine there is scope to improve the code too.
I'd maybe do something like this.
Note you can just open the summary workbook once before looping over the files.
Sub SummarizeFiles()
'Use `Const` for fixed values
Const FPATH As String = "C:\Test\" 'for example
Const TOT_WB As String = "Totals.xlsx"
Const TOT_WS As String = "Totals"
Dim FileName As String, wbTot As Workbook, wsDest As Worksheet
'does the "totals" workbook exist?
'if not then create it, else open it
If Dir(FPATH & TOT_WB) = "" Then
Set wbTot = Workbooks.Add
wbTot.Sheets(1).Name = TOT_WS
wbTot.SaveAs FPATH & TOT_WB
Else
Set wbTot = Workbooks.Open(FPATH & TOT_WB)
End If
Set wsDest = wbTot.Worksheets(TOT_WS)
FileName = Dir(FPATH & "*.xlsx")
Do While Len(FileName) > 0
If FileName <> TOT_WB Then 'don't try to re-open the totals wb
With Workbooks.Open(FPATH & FileName)
.Worksheets("Weekly Totals").Range("A2:M6").Copy _
wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1)
.Close False 'no changes
End With
End If
wbTot.Save
FileName = Dir 'next file
Loop
End Sub
I've got a loop that will take contents from 3 worksheets in a folder, and paste them onto a different workbook. I'd like to name them all a number. 1, 2, and 3 in the new workbook for use later while manipulating data.
I've tried naming a variable but I can't figure out how to have it increase by 1 each time.
Sub find()
Dim iIndex As Integer
Dim ws As Excel.Worksheet
Dim wb As Workbook
Dim strPath As String
Dim strFile As String
Dim i As Integer
i = 1
strPath = "P:\SD\SUPPORT\File Load\"
strFile = Dir(strPath & "*.xls")
Do While strFile <> ""
Set wb = Workbooks.Open(Filename:=strPath & strFile)
For iIndex = 1 To wb.Worksheets.Count
Set ws = wb.Worksheets(iIndex)
'Copy each worksheet into dual sub workbook
ActiveSheet.Copy After:=Workbooks("Dual Sub.xlsm").Sheets(4)
ActiveSheet.Name = i + 1
Next iIndex
strFile = Dir 'This moves the value of strFile to the next file.
Loop
End Sub
With this code it just names the first sheet '2', and gives an error that it cannot name multiple sheets the same thing. I'd like for each sheet to be named as 1, 2, and 3.
If I understood your logic, this should do the trick:
Option Explicit
Sub find()
Dim ws As Worksheet
Dim wb As Workbook
Dim Masterwb As Workbook
Set Masterwb = Workbooks("Dual Sub.xlsm")
Dim strPath As String
Dim strFile As String
strPath = "P:\SD\SUPPORT\File Load\"
strFile = Dir(strPath & "*.xls")
Dim i As Long
i = i + 1
Do While strFile <> ""
Set wb = Workbooks.Open(Filename:=strPath & strFile)
For Each ws In wb.Worksheets 'better to loop like this (you loop trhough every item in the workbooks.worksheets collection)
ws.Copy After:=Masterwb.Sheets(Masterwb.Sheets.Count) 'copy the worksheet on the new workbook to the last index on the master workbook
Masterwb.Sheets(Masterwb.Sheets.Count).Name = i 'name the last sheet on the master workbook the value of i starting from 1
i = i + 1
Next ws
strFile = Dir 'This moves the value of strFile to the next file.
Loop
End Sub
I am trying to pull data from a worksheet in another workbook and it isn't working properly. I'm not getting an error in the code but it is not pulling the data from the worksheet I want but rather whatever worksheet is open when the workbook opens. I read somewhere that there is no need to activate the worksheet so I am not sure what is wrong with the following code:
Dim prfile1 As String
Dim prfile2 As String
Dim filepath As String
Dim checktotal As Integer
Dim checkrng As Range
Dim emunber As String
prfile1 = Worksheets("setup").Range("B10").Value
prfile2 = Worksheets("setup").Range("B7").Value
filepath = Worksheets("setup").Range("e10").Value
emunber = Worksheets("ReprintOld").Range("V3").Value
Workbooks.Open filepath & prfile2
Windows(prfile2).Activate
Sheets(emunber).Activate
checktotal = Workbooks(prfile2).Worksheets(emunber).Range("AE1")
With Workbooks(prfile2).Worksheets(emunber)
Set checkrng = Range(Range("U5"), Range("U" & 4 + checktotal).End(xlDown))
End With
Windows(prfile1).Activate
MsgBox emunber
MsgBox checktotal
MsgBox checkrng.Address
The error occurs on the Open.Workbooks MasterFile line. I get the error of "This file cannot be found. Has it been removed, renamed, or replaced?" I used the fso.FileExist function to make sure the file does actually exist, and when I debug.print, the file name is exactly as it is specified in the variable MasterFile. Why won't VBA recognize this .xlsm file?
Sub ProcessData()
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
Dim fil As Scripting.File
Dim MyDir As String
Dim FolderSource As Scripting.Folder
'FolderSource is the fso enabled directory folder
Dim FolderDataSource As Scripting.Folder
'FolderDest is the fso enabled folder where the MasterFile is located
MyDir = "C:\Users..."
'MyDir is where all part number files will be stored
Dim MasterFile As String
Dim MasterFilePath As String
MasterFilePath = "C:\Users..."
MasterFile = "Function Master File.xlsm"
Dim wbSource As Workbook, wsSource As Worksheet
'The workbook and worksheet source will be the Master FIle
Dim wbDest As Workbook, wsDest As Worksheet
'The destination workbook and worksheet corresponding to the part number file
Dim myArray As Variant
Dim myTable As ListObject
Dim x As Long
myArray = Range("D13:D17")
'Array will draw from part number values that are entered in the appropriate area on the template
'Creating files for all new part numbers
Set FolderSource = fso.GetFolder(MyDir)
'For Each fil In FolderSource.Files
For x = LBound(myArray) To UBound(myArray)
If myArray(x, 1) <> "" Then
PartNumFile = MyDir & "\" & myArray(x, 1) & ".xlsx"
If Not fso.FileExists(PartNumFile) Then
Set newbook = Workbooks.Add
With newbook
.SaveAs Filename:=PartNumFile
End With
End If
End If
'Searching for the Part Number Data in the Master File
Set FolderDataSource = fso.GetFolder(MasterFilePath)
For Each fil In FolderDataSource.Files
Debug.Print fil.Name
If fso.FileExists(MasterFilePath & "\" & MasterFile) Then
Debug.Print fil.Name
Workbooks.Open MasterFile
Set wbSource = Workbooks(MasterFile)
Set wsSource = wbSource.Worksheets(1)
lrSource = wsSource.Range("A" & wsSource.Rows.Count).End(xlUp).Row
Set wbDest = Workbooks(myArray(x, 1) & ".xlsx")
Set wsDest = wbDest.Worksheets(1)
lrDest = wsDest.Range("A" & wsDest.Rows.Count).End(xlUp).Row + 1
wsSource.Range("A2:V" & lrSource).Copy Destination:=wsDest.Range("A" & lrDest)
End If
Next
Next
End Sub