VB script, VBA, BAT, copy-paste data

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

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?

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.

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.

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

@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.

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

Select allOpen in new window

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

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.

Hello Rob,

Thank you for your feedback the script is now working however I have some remarks and issues:

Thank you in advance for your help.

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

Select allOpen in new window

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.

Where is the header in your Report files? Is it in row 1? Yes, I'll keep the info in a log file.

Rob.

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.

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.

Great, thank you again for your help.

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

Select allOpen in new window

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!

Great, tested and it works, thank you!

No problem.

Rob.