PDA

View Full Version : Copying Same Range in Multiple Workbooks Worksheets to Columns in a Master Workbook



kewiopex
11-08-2016, 12:31 PM
Dear Experts
I have tried to put together various bits of code from examples to do as described below but being a newbie, I have not been successful. I am getting an error that says object not support this property or method but I know that there are others. I am way over my head but I am learning and this is the exciting part.

Here is what I would like to do:

1. Using an identified path containing that have the required workbook files, open the workbooks, then go through each worksheet and copy the specified range of cells ( this range is the same for each worksheet - C3-C10).
These copied ranges would then be pasted into adjacent columns of a specific worksheet ( GraphData) of a master workbook (MasterGen).

I do have some additional conditions that I do not know how to do:
1. When using MacOs (mac), how do you specify the path for the "Const sPath"?
2. How do I specify that the "Definition" worksheet to be excluded from the selection, for both the workbooks sources and the master? I have tried to code this.
3. How can I title each copied column in the master with the source worksheet name?


Option Explicit
Sub CombineMultipleFiles()
Const sPath = "c:\"

Dim sFile As String
Dim wbkSource As Workbook
Dim wSource As Worksheet
Dim wTarget As Worksheet
Dim lColumns As Long
Dim lMaxSourceColumn As Long
Dim lMaxTargetColumn As Long

On Error GoTo ErrHandler
Application.ScreenUpdating = False

Set wTarget = ActiveWorkbook.Worksheets("GraphData")
lColumns = wTarget.Columns.Count
sFile = Dir(sPath & "*.xls*")
Do While Not sFile = ""
Set wbkSource = Workbooks.Open(Filename:=sPath & sFile, AddToMRU:=False)
For Each wSource In wbkSource.Worksheets
If wSource.Name <> wSource("Definition") Then
lMaxSourceColumn = wSource.Cells(lColumns, 1).End(xlUp).Column
lMaxTargetColumn = wTarget.Cells(1, lColumns).End(xlToLeft).Column
wSource.Range("C3:C10").Copy Destination:=wTarget.Cells(lMaxTargetColumn + 1, 3)
wbkSource.Close SaveChanges:=False
sFile = Dir
End If
Next
Loop

ExitHandler:
Application.ScreenUpdating = True
Exit Sub

ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub

mancubus
11-08-2016, 02:30 PM
upload MasterGen.xlsm with the desired output.

as i am attending a 2-day seminar, i may not be around but i am sure other helpers on this forum will give you the pointers to resolve your requirement.

kewiopex
11-08-2016, 03:51 PM
Great. Thank you for looking at when you return. I have reposted the updated Master file that has the outcomes expected when the macro runs

mancubus
11-10-2016, 09:00 AM
1 it's the same file
2 i cant consolidate values as in your workbooks

before consolidation


20


23


18


10


15


25


8


4



after consolidation


y


t


r


e


x


c


d



3 manually do athe things you have requested with these two files in MasterGen.

4 post your workbook with the desired output here.

kewiopex
11-10-2016, 02:51 PM
Dear mancubus
Your time and effort are much appreciated! This is driving me crazy since I do not possess the skills. But I am eager.
I apologize for incorrectly posting the master file that did not have the outcomes. It is now attached.
You can well imagine the issues with handling up to 20 files with multiple sheets. This has all been done manually.

mancubus
11-11-2016, 12:53 AM
i am not an expert on Mac, and i dont have MSO for Mac installed on my machine. therefore i cant test it right now.

Google is my best friend here. :)

so test it with a copy of your file.



Sub vbax_57678_cons_multi_ws_wb_mac()

Dim sPath As String, sFile As String
Dim wbkSource As Workbook
Dim wSource As Worksheet, wTarget As Worksheet

Application.ScreenUpdating = False

Set wTarget = ThisWorkbook.Worksheets("GraphData")

sPath = "Macintosh HD:Users:kk:Desktop:Testexcel:"
ChDir sPath
sFile = Dir("")

Do While sFile <> ""
Workbooks.Open Filename:=sPath & sFile
With ActiveWorkbook
For Each wSource In .Worksheets
If wSource.Name <> "Definition" Then
Set PasteRng = wTarget.Cells(2, Columns.Count).End(xlToLeft).Offset(, 1)
PasteRng.Value = sFile & "_" & wSource.Name
ws.Range("C3:C10").Copy
PasteRng.Offset(1).PasteSpecial
End If
Next wSource
.Close False
End With
sFile = Dir
Loop

End Sub

kewiopex
11-11-2016, 12:27 PM
Dear mancubus
When I ran it on the mac, I had an unrecognized format file error.
With my friend google, I discovered that mac excel has an issue with Dir and therefore looping. I will try it on my friends windows machine to see what happens until I can revise the code for the code. One solution is "In the macro we call GetFilesOnMacWithOrWithoutSubfolders function like this to fill the MyFiles string". See below for the code. I will also try this. If I may I do wish to respond back to you once I have tried these methods.
1.Another option would be to just activate all the files but this is potentially a lot of files? Any suggestions here?

As always, I thank you for all your great support.

Call GetFilesOnMacWithOrWithoutSubfolders(Level:=1, ExtChoice:=0, FileFiltthankion:=0, FileNameFilterStr:="SearchString")

This are the four arguments that you can set in the function call :

'Level : 1= Only the files in the folder, 2 to ? levels of subfolders
'ExtChoice :0=(xls|xlsx|xlsm|xlsb), 1=xls , 2=xlsx, 3=xlsm, 4=xlsb, 5=csv, 6=txt, 7=all files, 8=(xlsx|xlsm|xlsb), 9=(csv|txt)
'FileFilterOption : 0=No Filter, 1=Begins, 2=Ends, 3=Contains
'FileNameFilterStr : Search string used when FileFilterOption = 1, 2 or 3

mancubus
11-13-2016, 11:25 AM
this may give you a start. i am not sure. :)



Sub vbax_57678_cons_multi_ws_wb_mac()
'uses GetFilesOnMacWithOrWithoutSubfolders function from:
'https://msdn.microsoft.com/en-us/library/office/jj613789(v=office.14).aspx

Dim MyFiles As String
Dim Mybook As Workbook
Dim wSource As Worksheet, wTarget As Worksheet
Dim MySplit
Dim FileInMyFiles As Long, CalcMode As Long

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

Set wTarget = ThisWorkbook.Worksheets("GraphData")

MyFiles = ""

Call GetFilesOnMacWithOrWithoutSubfolders(Level:=1, ExtChoice:=0, FileFilterOption:=0, FileNameFilterStr:="")
'Level : 1= Only the files in the folder you select, 2 to ? levels of subfolders
'ExtChoice : 0=(xls|xlsx|xlsm|xlsb), 1=xls , 2=xlsx, 3=xlsm, 4=xlsb, 5=csv, 6=txt, 7=all files, 8=(xlsx|xlsm|xlsb), 9=(csv|txt)
'FileFilterOption : 0=No Filter, 1=Begins, 2=Ends, 3=Contains
'FileNameFilterStr : Search string used when FileFilterOption = 1, 2 or 3

If MyFiles <> "" Then
MySplit = Split(MyFiles, Chr(10))
For FileInMyFiles = LBound(MySplit) To UBound(MySplit) - 1
Set Mybook = Workbooks.Open(MySplit(FileInMyFiles))
With Mybook
For Each wSource In .Worksheets
If wSource.Name <> "Definition" Then
Set PasteRng = wTarget.Cells(2, Columns.Count).End(xlToLeft).Offset(, 1)
PasteRng.Value = MySplit(FileInMyFiles) & "_" & wSource.Name
wSource.Range("C3:C10").Copy
PasteRng.Offset(1).PasteSpecial
End If
Next wSource
.Close False
End With
Next FileInMyFiles
End If

With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With

End Sub

kewiopex
11-13-2016, 03:15 PM
Dear mancubus

Pure genius! I did some minor tweaking and it works like a charm. I previously failed to mention that the version of excel is Excel for Mac 2011 which has special needs for working around the file and directory. I have the code with all its tweaks that I did below. Now could I ask you for a big favour to tweak iit for those with Windows excel. I will be buying the Windows version, and Parallels to run it on the Mac to avoid these issues in the future.
Thank you once again. I am so relieved and it is because of your persistence and skills.

Sub Test()


Dim MyPath As String
Dim MyScript As String
Dim MySplit As Variant
Dim Mybook As Workbook
Dim OneFile As Boolean
Dim wSource As Worksheet, wTarget As Worksheet
Dim MyFiles As String
Dim FileInMyFiles As Long, CalcMode As Long

Set wTarget = ThisWorkbook.Worksheets("GraphData")
FileFormat = "{""org.openxmlformats.spreadsheetml.sheet""}"

OneFile = False
On Error Resume Next:
MyPath = "Macintosh HD:Users:kk:Desktop:Testexcel:"

If Val(Application.Version) < 15 Then
'This is Mac Excel 2011
If OneFile = True Then
MyScript = _
"set theFile to (choose file of type" & _
" " & FileFormat & " " & _
"with prompt ""Please select a file"" default location alias """ & _
MyPath & """ without multiple selections allowed) as string" & vbNewLine & _
"return theFile"
Else
MyScript = _
"set applescript's text item delimiters to {ASCII character 10} " & vbNewLine & _
"set theFiles to (choose file of type" & _
" " & FileFormat & " " & _
"with prompt ""Please select a file or files"" default location alias """ & _
MyPath & """ with multiple selections allowed) as string" & vbNewLine & _
"set applescript's text item delimiters to """" " & vbNewLine & _
"return theFiles"
End If
End If

MyFiles = MacScript(MyScript)
On Error GoTo 0

If MyFiles <> "" Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With

MySplit = Split(MyFiles, Chr(10))
If MyFiles <> "" Then
MySplit = Split(MyFiles, Chr(10))
For FileInMyFiles = LBound(MySplit) To UBound(MySplit)
Set Mybook = Workbooks.Open(MySplit(FileInMyFiles))
With Mybook
For Each wSource In .Worksheets
If wSource.Name <> "Definition" Then
Set PasteRng = wTarget.Cells(2, Columns.Count).End(xlToLeft).Offset(, 1)
PasteRng.Value = wSource.Name
wSource.Range("C3:C10").Copy
PasteRng.Offset(1).PasteSpecial xlPasteValues
End If
Next wSource
.Close False
End With
Next FileInMyFiles
End If

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
End Sub

jdigennaro
03-20-2017, 11:14 AM
How would I convert this to run on the Windows platform?

mancubus
03-29-2017, 06:57 AM
start your own thread in excel forum