• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 254
  • Last Modified:

VB script, VBA, BAT, copy-paste data

Hello Experts

I have a ROOT folder wih many subfolders
In each subfolder there is a xls file with a name which begins with “report” char.
Every file contains a sheet with the following name “portfolio”.
I also have a Portfolio.xls in the ROOT folder.

I need a VB script / Bat or VBA which do the following.

Open Portfolio.xls (placed at ROOT folder)
Select Portfolio sheet.
Copy data without header from Portfolio sheet (this file contains only one sheet with exactly the same number of columns of portfolio sheet placed in every report.xls
Open sequentially every report_xxxx.xls report placed at subfolder 1, subfolder 2, etc…
Select Portfolio sheet, reset data without the header and copy the data from Portfolio sheet placed at root folder.

Thank you very much for your help.

Regards,
0
LD16
Asked:
LD16
  • 9
  • 8
  • 3
  • +1
1 Solution
 
Steve KnightIT ConsultancyCommented:
For batch file you can pretty well forget it.  VBScript can access Excel but personally I would do it with a "master" excel sheet with VBA code in there that you open to control this and or any processses you need for the others.

I don't have time to write it at the moment but will see if I can look back later if someone else doesn't make you one.

Hoe many report sheets are you talking about.... 10, 20, 100's, 1000's ?

Steve
0
 
Chris PfeifferMilitaryCommented:
Am I understanding you want to take the data from each Portfolio sheet form all subfolders and append it to the list on Portfolio.xls in the root folder.  This would then make one large list will all data on the sheet located in the ROOT folder?
0
 
Steve KnightIT ConsultancyCommented:
Would suggest also that you zip up and attach a copy of your main sheet and the other ones - if they have more than sheet just need the relevant ones for this.
0
Cloud Class® Course: C++ 11 Fundamentals

This course will introduce you to C++ 11 and teach you about syntax fundamentals.

 
LD16Author Commented:
Something is not clear in the requirements.

Here are the revised requirements:

1 Copy Portfolio data from Portfolio.xls (Portfolio sheet) without header located at rool
2-Reset all the data from every “report_xxxx.xls” (Portfolio sheet) located in ROOT/SUB1, ROOT/SUB2, etc…
3-Paste the data from Portfolio sheet of the Portfolio.xls into Portfolio sheet of every report_xxxx.xls and not the opposit.
0
 
Steve KnightIT ConsultancyCommented:
Just another quick question too, probably clearer if we look at them. Is there some special data in the root portfolio sheet and is there any reason why the other sheets don't just lookup into the main sheet rather than having a copy?

You could also have a "reset" button in the report sheets that goes away and looks up the root one and pulls the data into it rather than pushing the data in?

All depends who does what with the sheets etc. and whether the data is static once it gets in the report sheets or is then updated etc?

Steve
0
 
LD16Author Commented:
@Steve Knight thank you for your remarks
1-The portfolio report is automatically generated in the ROOT folder. this is why I need to catch data from this report.
2- The thing is that I have multiple report_xxx.xls so It will be time consuming to open each repor_xxx.xls  reset and copy the data from Portfolio.xls.
0
 
RobSampsonCommented:
Hi, here's my version of how this would work.  I suggest you make a backup copy of your data, and run the script over that.  All you should need to change is the strInputFolder value.

I made the assumption that the header always exists in all sheets, and the data is only to be copied from A2 onwards, into A2 of the target sheet.

Regards,

Rob.

strInputFolder = "C:\Temp\Scripts\Excel"
If Right(strInputFolder, 1) <> "\" Then strInputFolder = strInputFolder & "\"
strMasterWB = strInputFolder & "Portfolio.xls"
strSheetName = "Portfolio"

Set objFSO = CreateObject("Scripting.FileSystemObject")
Const xlUp = -4162
Const xlToLeft = -4159
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
If objFSO.FileExists(strMasterWB) = False Then
	WScript.Echo strMasterWB & " could not be found. Cannot copy data."
Else
	Set objMasterWB = objExcel.Workbooks.Open(strMasterWB, False, False)
	Set objMasterSheet = objMasterWB.Sheets(strSheetName)
	intLastRow = objMasterSheet.Cells(65536, 1).End(xlUp).Row
	intLastCol = objMasterSheet.Cells(1, 256).End(xlToLeft).Column
	Set rngToCopy = objMasterSheet.Range("A2:" & objMasterSheet.Cells(intLastRow, intLastCol).Address)
	For Each objSubFolder In objFSO.GetFolder(strInputFolder).SubFolders
		RecurseFolder objFSO.GetFolder(strInputFolder)
	Next
End If
objMasterWB.Close False
objExcel.Quit
WScript.Echo "Done"

Sub RecurseFolder(objSubFldr)
	For Each objSubFolder2 In objSubFldr.SubFolders
		RecurseFolder objSubFolder2
	Next
	For Each objFile In objSubFldr.Files
		If LCase(Right(objFile.Name, 4)) = ".xls" And Left(LCase(objFile.Name), 6) = "report" Then
			Set objWB = objExcel.Workbooks.Open(objFile.Path, False, False)
			On Error Resume Next
			Set objSheet = objWB.Sheets(strSheetName)
			If Err.Number = 0 Then
				Err.Clear
				On Error Goto 0
				' Clear the range in the subfolder report
				intLastRow = objSheet.Cells(65536, 1).End(xlUp).Row
				intLastCol = objSheet.Cells(1, 256).End(xlToLeft).Column
				Set rngToClear = objSheet.Range("A2:" & objSheet.Cells(intLastRow, intLastCol).Address)
				rngToClear.Clear
				rngToCopy.Copy objSheet.Range("A2")
			End If
			Err.Clear
			On Error Goto 0
			objWB.Close False
		End If
	Next
End Sub

Open in new window

0
 
LD16Author Commented:
Hello Rob,
I tried your script but the paste action is not performed. I am able to open and copy the portfolio.xls however the script doesn’t open the various reports_xxx.xls and paste the data in report (sheet).

Just to clarify :
Portfolio.xls is under:
C:\ROOT
reports_xxx.xls.are under :
C:\ROOT\sub1
C:\ROOT\sub2
….

Thank you in advance for your help
0
 
RobSampsonCommented:
Oh! Oops!

Line 48 is this:
                  objWB.Close False

it should be
                  objWB.Close True

So that it actually saves the changes to the workbooks.

Please change that line, and it should work.

Regards,

Rob.
0
 
LD16Author Commented:
Hello Rob,

Thank you for your feedback the script is now working however I have some remarks and issues:
The reset in report sheet of destination files under subfolders is not properly done as I remove 10 lines in portfolio reference file in order to have 25 lines and  in destination report files I have 25 lines in column (A) however in the rest  of lines I still having the 35 lines before the removal. So I think that the clear / reset data of report files under Subfolders is done just for column A
Is there a way to have something like Application.Screenupdating = False in order to hide all the workbooks open and make it faster the script?

Thank you in advance for your help.
0
 
RobSampsonCommented:
Can you run this version of the code so we can see where it might be failing?

It will launch a command prompt and show you some output about what ranges it has detected to copy and clear.

Regards,

Rob.

If LCase(Right(Wscript.FullName, 11)) = "wscript.exe" Then
    strPath = Wscript.ScriptFullName
    strCommand = "%comspec% /k cscript  """ & strPath & """"
    Set objShell = CreateObject("Wscript.Shell")
    objShell.Run(strCommand), 1, True
    Wscript.Quit
End If

strInputFolder = "C:\Temp\Scripts\Excel"
If Right(strInputFolder, 1) <> "\" Then strInputFolder = strInputFolder & "\"
strMasterWB = strInputFolder & "Portfolio.xls"
strSheetName = "Portfolio"

Set objFSO = CreateObject("Scripting.FileSystemObject")
Const xlUp = -4162
Const xlToLeft = -4159
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
objExcel.ScreenUpdating = False

If objFSO.FileExists(strMasterWB) = False Then
	WScript.Echo strMasterWB & " could not be found. Cannot copy data."
Else
	WScript.Echo "Opening portfolio at " & strMasterWB
	Set objMasterWB = objExcel.Workbooks.Open(strMasterWB, False, False)
	Set objMasterSheet = objMasterWB.Sheets(strSheetName)
	intLastRow = objMasterSheet.Cells(65536, 1).End(xlUp).Row
	intLastCol = objMasterSheet.Cells(1, 256).End(xlToLeft).Column
	Set rngToCopy = objMasterSheet.Range("A2:" & objMasterSheet.Cells(intLastRow, intLastCol).Address)
	WScript.Echo "Range that will be copied from master portfolio: " & rngToCopy.Address & vbCrLf
	For Each objSubFolder In objFSO.GetFolder(strInputFolder).SubFolders
		RecurseFolder objFSO.GetFolder(strInputFolder)
	Next
End If
objMasterWB.Close False
objExcel.ScreenUpdating = True
objExcel.Quit
WScript.Echo "Done"
MsgBox "Script finished. Type Exit to close the command prompt."

Sub RecurseFolder(objSubFldr)
	For Each objSubFolder2 In objSubFldr.SubFolders
		RecurseFolder objSubFolder2
	Next
	For Each objFile In objSubFldr.Files
		If LCase(Right(objFile.Name, 4)) = ".xls" And Left(LCase(objFile.Name), 6) = "report" Then
			WScript.Echo "Opening report file at " & objFile.Path
			Set objWB = objExcel.Workbooks.Open(objFile.Path, False, False)
			On Error Resume Next
			Set objSheet = objWB.Sheets(strSheetName)
			If Err.Number = 0 Then
				Err.Clear
				On Error Goto 0
				' Clear the range in the subfolder report
				intLastRow = objSheet.Cells(65536, 1).End(xlUp).Row
				intLastCol = objSheet.Cells(1, 256).End(xlToLeft).Column
				Set rngToClear = objSheet.Range("A2:" & objSheet.Cells(intLastRow, intLastCol).Address)
				WScript.Echo "Range that will be cleared from " & objFile.Name & ": " & rngToClear.Address
				rngToClear.Clear
				WScript.Echo "Copying master sheet range " & rngToCopy.Address & " to " & objFile.Name & " cell $A$2"
				rngToCopy.Copy objSheet.Range("A2")
			End If
			Err.Clear
			On Error Goto 0
			WScript.Echo "Closing " & objFile.Name & vbCrLf
			objWB.Close True
		End If
	Next
End Sub

Open in new window

0
 
LD16Author Commented:
Hello Rob,

I made the test and based on the cmd the copy take into account all the used range from portfolio. However  the clear is not properly done as it just take into account the used range of column A.
The cmd ouput is excellent can we add a logfile which contains the various information instead of having in cmd?

Thank you again for your help.
0
 
RobSampsonCommented:
Where is the header in your Report files? Is it in row 1? Yes, I'll keep the info in a log file.

Rob.
0
 
LD16Author Commented:
Yes it is in row 1, however when I launched the script for the first time the header (line 1) was removed so I think this explain that the paste is done just for column A.
To solve this problem can we try to:
 
Select used range of Portfolio sheet (including the header).
Reset all used range of reports files Portfolio sheet (including the header).
Select cell (A1) of reports files Portfolio sheet and paste all the data from Portfolio sheet into reports files Portfolio sheet .

This can probably solve the problem.

Thank you in advance for your help.
0
 
RobSampsonCommented:
That makes more sense. I was wondering why you wanted to avoid the headers, since they should be the same anyway, I would have thought.  I'll try to get to this tonight.

Rob.
0
 
LD16Author Commented:
Great, thank you again for your help.
0
 
RobSampsonCommented:
Hi, had time at lunch to change this.  Give this a shot.

Regards,

Rob.

If LCase(Right(Wscript.FullName, 11)) = "wscript.exe" Then
    strPath = Wscript.ScriptFullName
    strCommand = "%comspec% /k cscript  """ & strPath & """"
    Set objShell = CreateObject("Wscript.Shell")
    objShell.Run(strCommand), 1, True
    Wscript.Quit
End If

strInputFolder = "C:\Temp\Scripts\Excel"
If Right(strInputFolder, 1) <> "\" Then strInputFolder = strInputFolder & "\"
strLogFile = strInputFolder & "PortFolio_Log.txt"
strMasterWB = strInputFolder & "Portfolio.xls"
strSheetName = "Portfolio"

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objLog = objFSO.OpenTextFile(strLogFile, 8, True)

Const xlUp = -4162
Const xlToLeft = -4159
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
objExcel.ScreenUpdating = False

If objFSO.FileExists(strMasterWB) = False Then
	WriteMessage strMasterWB & " could not be found. Cannot copy data."
Else
	WriteMessage "Opening portfolio at " & strMasterWB
	Set objMasterWB = objExcel.Workbooks.Open(strMasterWB, False, False)
	Set objMasterSheet = objMasterWB.Sheets(strSheetName)
	'intLastRow = objMasterSheet.Cells(65536, 1).End(xlUp).Row
	'intLastCol = objMasterSheet.Cells(1, 256).End(xlToLeft).Column
	'Set rngToCopy = objMasterSheet.Range("A2:" & objMasterSheet.Cells(intLastRow, intLastCol).Address)
	Set rngToCopy = objMasterSheet.UsedRange
	WriteMessage "Range that will be copied from master portfolio: " & rngToCopy.Address & vbCrLf
	For Each objSubFolder In objFSO.GetFolder(strInputFolder).SubFolders
		RecurseFolder objFSO.GetFolder(strInputFolder)
	Next
End If
objMasterWB.Close False
objExcel.ScreenUpdating = True
objExcel.Quit
objLog.Close
WriteMessage "Done"
MsgBox "Script finished. Type Exit to close the command prompt."

Sub RecurseFolder(objSubFldr)
	For Each objSubFolder2 In objSubFldr.SubFolders
		RecurseFolder objSubFolder2
	Next
	For Each objFile In objSubFldr.Files
		If LCase(Right(objFile.Name, 4)) = ".xls" And Left(LCase(objFile.Name), 6) = "report" Then
			WriteMessage "Opening report file at " & objFile.Path
			Set objWB = objExcel.Workbooks.Open(objFile.Path, False, False)
			On Error Resume Next
			Set objSheet = objWB.Sheets(strSheetName)
			If Err.Number = 0 Then
				Err.Clear
				On Error Goto 0
				' Clear the range in the subfolder report
				'intLastRow = objSheet.Cells(65536, 1).End(xlUp).Row
				'intLastCol = objSheet.Cells(1, 256).End(xlToLeft).Column
				'Set rngToClear = objSheet.Range("A2:" & objSheet.Cells(intLastRow, intLastCol).Address)
				Set rngToClear = objSheet.UsedRange
				WriteMessage "Range that will be cleared from " & objFile.Name & ": " & rngToClear.Address
				rngToClear.Clear
				WriteMessage "Copying master sheet range " & rngToCopy.Address & " to " & objFile.Name & " cell $A$2"
				rngToCopy.Copy objSheet.Range("A1")
			End If
			Err.Clear
			On Error Goto 0
			WriteMessage "Closing " & objFile.Name & vbCrLf
			objWB.Close True
		End If
	Next
End Sub

Sub WriteMessage(strMessage)
	WScript.Echo strMessage
	objLog.WriteLine Now & ": " & strMessage
End Sub

Open in new window

0
 
LD16Author Commented:
Hello Rob,
Sorry for the delay I thought I had replied to this. It works perfectly. Just a small remark. Is it possible to:
add a usedrange.clearformats of objsheet of destworkbook 'report'
And to create a new variable to distinguish:
strSheetname the reference sheet of portfolio.xls (already set up)
desSheetname  the sheet in report.xls located in every subfolder in which all the data from strSheetname will be pasted and in which the format will be reset.
Thank you very much!
0
 
RobSampsonCommented:
Sure.  You seem to understand what needs to be added, so that makes it easy for me ;-)

I have done that for you.  I have changed the source sheet variable to strSourceSheetName and the destination one is strDestSheetName.

Rob.

If LCase(Right(Wscript.FullName, 11)) = "wscript.exe" Then
    strPath = Wscript.ScriptFullName
    strCommand = "%comspec% /k cscript  """ & strPath & """"
    Set objShell = CreateObject("Wscript.Shell")
    objShell.Run(strCommand), 1, True
    Wscript.Quit
End If

strInputFolder = "C:\Temp\Scripts\Excel"
If Right(strInputFolder, 1) <> "\" Then strInputFolder = strInputFolder & "\"
strLogFile = strInputFolder & "PortFolio_Log.txt"
strMasterWB = strInputFolder & "Portfolio.xls"
strSourceSheetName = "Portfolio"
strDestSheetName = "Portfolio"

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objLog = objFSO.OpenTextFile(strLogFile, 8, True)

Const xlUp = -4162
Const xlToLeft = -4159
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
objExcel.ScreenUpdating = False

If objFSO.FileExists(strMasterWB) = False Then
	WriteMessage strMasterWB & " could not be found. Cannot copy data."
Else
	WriteMessage "Opening portfolio at " & strMasterWB
	Set objMasterWB = objExcel.Workbooks.Open(strMasterWB, False, False)
	Set objMasterSheet = objMasterWB.Sheets(strSourceSheetName)
	'intLastRow = objMasterSheet.Cells(65536, 1).End(xlUp).Row
	'intLastCol = objMasterSheet.Cells(1, 256).End(xlToLeft).Column
	'Set rngToCopy = objMasterSheet.Range("A2:" & objMasterSheet.Cells(intLastRow, intLastCol).Address)
	Set rngToCopy = objMasterSheet.UsedRange
	WriteMessage "Range that will be copied from master portfolio: " & rngToCopy.Address & vbCrLf
	For Each objSubFolder In objFSO.GetFolder(strInputFolder).SubFolders
		RecurseFolder objFSO.GetFolder(strInputFolder)
	Next
End If
objMasterWB.Close False
objExcel.ScreenUpdating = True
objExcel.Quit
objLog.Close
MsgBox "Script finished. Type Exit to close the command prompt."

Sub RecurseFolder(objSubFldr)
	For Each objSubFolder2 In objSubFldr.SubFolders
		RecurseFolder objSubFolder2
	Next
	For Each objFile In objSubFldr.Files
		If LCase(Right(objFile.Name, 4)) = ".xls" And Left(LCase(objFile.Name), 6) = "report" Then
			WriteMessage "Opening report file at " & objFile.Path
			Set objWB = objExcel.Workbooks.Open(objFile.Path, False, False)
			On Error Resume Next
			Set objSheet = objWB.Sheets(strDestSheetName)
			If Err.Number = 0 Then
				Err.Clear
				On Error Goto 0
				' Clear the range in the subfolder report
				'intLastRow = objSheet.Cells(65536, 1).End(xlUp).Row
				'intLastCol = objSheet.Cells(1, 256).End(xlToLeft).Column
				'Set rngToClear = objSheet.Range("A2:" & objSheet.Cells(intLastRow, intLastCol).Address)
				Set rngToClear = objSheet.UsedRange
				WriteMessage "Range that will be cleared from " & objFile.Name & ": " & rngToClear.Address
				rngToClear.Clear
				rngToClear.ClearFormats
				WriteMessage "Copying master sheet range " & rngToCopy.Address & " to " & objFile.Name & " cell $A$2"
				rngToCopy.Copy objSheet.Range("A1")
			End If
			Err.Clear
			On Error Goto 0
			WriteMessage "Closing " & objFile.Name & vbCrLf
			objWB.Close True
		End If
	Next
End Sub

Sub WriteMessage(strMessage)
	WScript.Echo strMessage
	objLog.WriteLine Now & ": " & strMessage
End Sub

Open in new window

0
 
LD16Author Commented:
Great, tested and it works, thank you!
0
 
RobSampsonCommented:
No problem.

Rob.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Cloud Class® Course: MCSA MCSE Windows Server 2012

This course teaches how to install and configure Windows Server 2012 R2.  It is the first step on your path to becoming a Microsoft Certified Solutions Expert (MCSE).

  • 9
  • 8
  • 3
  • +1
Tackle projects and never again get stuck behind a technical roadblock.
Join Now