i am new to vb script and dont know much so please help.
I have a folder, which consists of many sub-folders . Each sub-folder has 10+ excel sheets in it. My aim is to copy the data from each and every excel file from all the sub-folders to a single excel sheet. the problem is i have written a code, but it is overwriting so the data gets deleted. And we have same header in all the excel files, i want the header to appear only once in the main excel sheet .
please help and thnakyou in advance.
'Sub RunCodeOnAllXLSFiles()
On Error Resume Next
Set objExcel = CreateObject("Excel.Application")
strPath = ":\Documents and Settings\faizat\Desktop\leeza"
pathName="xlsx"
If strPath = "" Then WScript.quit
If pathName = "" Then WScript.quit
'Creating an Excel Workbook in My Documents
Set objWorkbook2= objExcel.Workbooks.Add()
objExcel.Visible = True
objExcel.DisplayAlerts = False
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder (strPath)
Set objsubFolder = objfolder.subFolders
Set objfile = objsubfolder.files
For Each objsubfolder In objfolder.subfolders
For Each objFile In objsubFolder.Files
If objFso.GetExtensionName (objFile.Path) = "xlsx" Then
Set objWorkbook = objExcel.Workbooks.Open(objFile.Path)
Set objWorksheet = objWorkbook.WorkSheets(1)
objworksheet.Activate
' Select the range on Sheet1 you want to copy
objWorkbook.Worksheets("SHEET1").usedrange.Copy
objworkbook.close
Set objRange = objExcel.Range("A2")
intNewRow = objExcel.ActiveCell.Row + 10
strNewCell = "A" & intNewRow
objExcel.Range(strNewCell).Activate
For i = 1 To usedrange
objWorksheet.Cells(intNewRow, 1) = i * 1
intNewRow = intNewRow + i
Next
' Paste it on sheet1 of workbook2, starting at A1
objWorkbook2.Worksheets("Sheet1").Range(strNewCell).PasteSpecial
Set objWorksheet = objWorkbook2.Worksheets(1)
End If
Next
Next
For i = 1 To usedrange
objWorksheet.Cells(intNewRow, 1) = i * 1
intNewRow = intNewRow + i
Next
You never initialize the variable usedrange, so your loop never increments intNewRow. Initialize intNewRow with the value 1 at the beginning of your script, and use something like this in the inner loop:
Set objWorkbook = objExcel.Workbooks.Open(objFile.Path)
If intNewRow = 1 Then
startrow = 1
Else
startrow = 2
End If
endrow = objWorkbook.Worksheets("SHEET1").UsedRange.Rows.Count
objWorkbook.Worksheets("SHEET1").Range(startrow & ":" & endrow).Copy
objWorkbook2.Worksheets("Sheet1").Cells(intNewRow, 1).PasteSpecial
objWorkbook.close
intNewRow = intNewRow + (endrow - startrow - 1)
Related
I've got this code but it pastes the cell formatting from the original document into the master file, how can I remove the formatting from the output please?
Option Explicit
Sub CopyPastefiles()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim MyFolder As String
Dim StartSht As Worksheet, ws As Worksheet
Dim WB As Workbook
Dim i As Integer
'turn screen updating off - makes program faster
'Application.ScreenUpdating = False
'location of the folder in which the desired TDS files are
MyFolder = "U:\Documents\DeleteMe\Sycle\"
Set StartSht = ActiveSheet
Set StartSht = Workbooks("masterfile.xlsx").Sheets("Sheet1")
'create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'get the folder object
Set objFolder = objFSO.GetFolder(MyFolder)
i = 1
'loop through directory file and print names
For Each objFile In objFolder.Files
If LCase(Right(objFile.Name, 3)) = "xls" Or LCase(Left(Right(objFile.Name, 4), 3)) = "xls" Then
'print file name to Column 1
Workbooks.Open Filename:=MyFolder & objFile.Name
Set WB = ActiveWorkbook
'print TOOLING DATA SHEET(TDS): values to Column 2
With WB
For Each ws In .Worksheets
StartSht.Cells(i + 1, 10) = objFile.Name
With ws
.Range("e6").Copy StartSht.Cells(i + 1, 4)
.Range("e7").Copy StartSht.Cells(i + 1, 5)
.Range("e8").Copy StartSht.Cells(i + 1, 6)
End With
i = i + 1
'move to next file
Next ws
'close, do not save any changes to the opened files
.Close SaveChanges:=False
End With
End If
'move to next file
Next objFile
'turn screen updating back on
'Application.ScreenUpdating = True
End Sub
thanks for you help.
Instead of using .Copy to directly paste the values into the destination, you can use .PasteSpecial Paste:=xlPasteValues.
I.e. something like
.Range("e6").Copy
StartSht.Cells(i + 1, 4).PasteSpecial Paste:=xlPasteValues
for your first line.
Or you can just set the cell equal to the range you're copying, as suggested in the comments on your question.
.StartSht.Cells(i + 1, 4) = .Range("E6")
I need to merge multiple xlsb files into one using vbscript, all of them have a header, but only a header of the first file is needed in this merge, headers of the other files should be ignored. Anyone has an idea how to do this?
I tried this code... it works well, but I need it to ignore the headers of the other files:
strPathSrc = "C:\Users\user\Documents\teste_merge\" ' Source files folder
strMaskSrc = "*.xlsb" ' Source files filter mask
iSheetSrc = 1 ' Sourse sheet index or name
strPathDst = "C:\Users\user\Documents\teste_merge\Result.xlsb" ' Destination file
iSheetDst = 1 ' Destination sheet index or name
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWorkBookDst = objExcel.Workbooks.Open(strPathDst)
Set objSheetDst = objWorkBookDst.Sheets(iSheetDst)
Set objShellApp = CreateObject("Shell.Application")
Set objFolder = objShellApp.NameSpace(strPathSrc)
Set objItems = objFolder.Items()
objItems.Filter 64 + 128, strMaskSrc
objExcel.DisplayAlerts = False
For Each objItem In objItems
Set objWorkBookSrc = objExcel.Workbooks.Open(objItem.Path)
Set objSheetSrc = objWorkBookSrc.Sheets(iSheetSrc)
GetUsedRange(objSheetSrc).Copy
Set objUsedRangeDst = GetUsedRange(objSheetDst)
iRowsCount = objUsedRangeDst.Rows.Count
objWorkBookDst.Activate
objSheetDst.Cells(iRowsCount + 1, 1).Select
objSheetDst.Paste
objWorkBookDst.Application.CutCopyMode = False
objWorkBookSrc.Close
Next
Function GetUsedRange(objSheet)
With objSheet
Set GetUsedRange = .Range(.Cells(1, 1), .Cells(.UsedRange.Row + .UsedRange.Rows.Count - 1, .UsedRange.Column + .UsedRange.Columns.Count - 1))
End With
End Function
I have a script that monitors the folders and putting the results in an excel file. Is there a method when a cell that has been changed after 30 minuts that it gets a green color gets? and if the cell has not been changed after 30 minutes it will get a red color?
I forgot to mention that I want to check multiple cells.
Here is a picture. everything under f
I hope this is clear since my English is not good. laatste import(last import) needs to be checked
My code:
'=====
Const adVarChar = 200
Const adDate = 7
Const adBigInt = 20
'==============================================================================
'Set objecten
Set WshShell = WScript.CreateObject("WScript.Shell")
set fso = createobject("scripting.filesystemobject")
set objPadImport = fso.getfolder("\\netko-sbs\data\imports\")
Set SubfolderImport = objPadImport.SubFolders
ExcelBestand = "\\netko-sbs\data\imports\output.xlsx"
Set objFile = FSO.OpenTextFile("C:\Users\Karim\Desktop\Vbscripttest\importV3\lokaties.txt", ForReading)
'Waarden
Const ForReading = 1
Dim arrFileLines()
i = 0
Do Until objFile.AtEndOfStream
Redim Preserve arrFileLines(i)
arrFileLines(i) = objFile.ReadLine
i = i + 1
Loop
objFile.Close
'==============================================================================
'WScript.Sleep 10000 'Sleeps for 10 seconds
'==============================================================================
'create a custom disconnected recordset
'with fields for filename and last modified date.
'==============================================================================
'Record set maken
'==============================================================================
set rs = createobject("ador.recordset")
rs.fields.append "foldername",adVarChar,255
rs.fields.append "moddate",adDate
rs.fields.append "naam",advarchar,255
rs.fields.append "tijd", advarchar,20
'==============================================================================
'Excel
Set objExcel = CreateObject("Excel.Application")
objExcel.DisplayAlerts = FALSE 'Foutmeldingen uitschakelen
Set objWorkbook = objExcel.Workbooks.Add() 'Bestand openen..
'objWorkbook.SaveAs(ExcelBestand)
objExcel.Visible = True 'toon excel
objExcel.Cells(1, 1).Value = "foldernaam" 'Header instellen
objExcel.Cells(1, 2).Value = "Laatste import" 'Header instellen
objExcel.Cells(1, 3).Value = "Controle tijd" 'Header instellen
x = 2 'set de juiste rij in excel.
'==============================================================================
rs.open
'=====
'load it with file name, date, etc. (mapen controleren)
'==============================================================================
'==============================================================================
For Each strLine in arrFileLines
s = split( strline, "," )
set folder = fso.getfolder( s(0) )
'set test = (folder.datelastmodified - s(2))
rs.addnew array("foldername","moddate", "naam", "tijd"), _
array(folder.name,folder.datelastmodified, s(1), s(2)) ',test)
rs.update
Next
s = "Sortering van Oud naar Nieuw:" & vbcrlf _
& "=============================" & vbcrlf
if not (rs.bof and rs.eof) then
rs.sort = "moddate asc"
rs.movefirst
do until rs.eof
objExcel.Cells(x, 1).Value = _
rs.Fields("naam").Value
objExcel.Cells(x, 2).Value = _
rs.Fields("moddate").Value
objExcel.Cells(x, 3).Value = _
rs.Fields("tijd").Value
x = x + 1
rs.movenext
loop
end if
'Excel
Set objRange = objExcel.Range("A1") 'Selecteer actieve cell
objRange.Activate 'Activeer cell
Set objRange = objExcel.ActiveCell.EntireColumn
objRange.Autofit() 'Set grootte van kolom
Set objRange = objExcel.Range("B1") 'Selecteer actieve cell
objRange.Activate 'Activeer cell
Set objRange = objExcel.ActiveCell.EntireColumn
objRange.Autofit() 'Set grootte van kolom
Set objRange = objExcel.Range("C1") 'Selecteer actieve cell
objRange.Activate 'Activeer cell
Set objRange = objExcel.ActiveCell.EntireColumn
objRange.Autofit() 'Set grootte van kolom
'==============================================================================
VarType moddate = objExcel.Cells(1, 1).Value = "Laatste import"
if DateDiff("n",moddate,Date) < 30 then
objExcel.Cells(y,y).Interior.ColorIndex = 3
Else objExcel.Cells(1,1).Interior.ColorIndex = 4
end if
'==============================================================================
ObjWorkbook.SaveAs(ExcelBestand) 'Excel bestand opslaan
'objExcel.Quit 'Excel afsluiten als nodig is.
'==============================================================================
'==============================================================================
'objFile.WriteLine s 'Schrijf waarden naar Excel
Set rs = nothing 'Gooi RS leeg
Set folder = nothing 'Object leegmaken
set fso = nothing 'Object leegmaken
set objPadImport = nothing
set objPadFrigo = nothing
set SubfolderFrigo = nothing
set objExcel = nothing
'==============================================================================
getlastmodified time of cell store it in one of cell or in variable.
for example :
if you store the time in one of cell then,
var lastmodifitime = objExcel.Cells(x,1).Value
'if cell value is modified in last 30 minutes then it set red, else if it not modified in last 30 minutes or more it set background Color green
if DateDiff("n",lastmodifitime,Date) < 30 then
objExcel.Cells(y,y).Interior.ColorIndex = 3
Else
objExcel.Cells(z,z).Interior.ColorIndex = 4
end if
' this link will help you to get last modified time : http://www.online-tech-tips.com/ms-office-tips/track-changes-in-excel/
You can use the Application.OnTime() function to call an Excel subroutine after a certain interval. If you're just trying to monitor a single cell, you could use a single flag to specify whether the cell's value has changed. The Worksheet_Change() event could be used to update the flag.
For example, in a Module, add the following code:
' Create global flag to indicate if cell value has changed.
Public CellChanged As Boolean
' Call this routine to start the monitor.
Public Sub StartMonitor()
CellChanged = False ' Init
Application.OnTime Now() + TimeValue("00:30:00"), "CheckIfChange"
End Sub
' This will be called by the monitor after 30 mins.
Public Sub CheckIfChange()
If CellChanged Then Sheet1.Cells(2, 2).Interior.Color = vbGreen
End Sub
Then, in your worksheet, just add a bit of code that updates the global flag if your target cell's value has changed.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row = 2 Then If Target.Column = 2 Then CellChanged = True
End Sub
below is the code to loop through all the excel workbook in every subfolder(looping through subfolders) and copying data from each and every excel workbook and appending onto another excel workbook. Excecuting the below code I am getting an error as "Object doesn't support this property or method:'objsubfolder.files'" please help me with this.
'Sub RunCodeOnAllXLSFiles()
Set objExcel = CreateObject("Excel.Application")
strPath = "C:\Documents and Settings\SupriyaS\Desktop\su"
pathName="xlsx"
if strPath = "" then Wscript.quit
if pathName = "" then Wscript.quit
'Creating an Excel Workbook in My Documents
Set objWorkbook2= objExcel.Workbooks.Add()
objExcel.Visible = True
objExcel.DisplayAlerts = False
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder (strPath)
Set objsubFolder = objfolder.subFolders
set objfile = objsubfolder.files
for each objsubfoleder in objfolder.subfolders
For Each objFile In objsubFolders.Files
If objFso.GetExtensionName (objFile.Path) = "xlsx" Then
Set objWorkbook = objExcel.Workbooks.Open(objFile.Path)
Set objWorksheet = objWorkbook.WorkSheets(1)
objworksheet.Activate
' Select the range on Sheet1 you want to copy
objWorkbook.Worksheets("SHEET1").usedrange.Copy
objworkbook.close
Set objRange = objExcel.Range("A1")
intNewRow = objExcel.ActiveCell.Row + 3
strNewCell = "A" & intNewRow
objExcel.Range(strNewCell).Activate
' Paste it on sheet1 of workbook2, starting at A1
objWorkbook2.Worksheets("Sheet1").Range(strNewCell).PasteSpecial
Set objWorksheet = objWorkbook2.Worksheets(1)
End If
next
next
Posted as answer just to be able to say:
USE Option Explicit
(and Dim and initialize all your variables (immediately) before first use)
to avoid to be bitten by typos like "objsubfoleder"
I'm working in VbScript to Copy all the worksheets of all the files in a folder in a single workbook and save it.
I have 4 workbooks. Each contains 1 worksheet.
worksheet 1 = 1 MB, worksheet 2 = 19 MB, worksheet 3 = 48 MB and worksheet 4 = 3 MB
The worksheets are copied properly in all the sheets except worksheet 3.
In worksheet 3, only 1/2 of the data is copied. What is the issue behind it?
Please find the code below. Thanks is advance.
'~~> Change Paths as applicable
Dim objExcel, objWorkbook, Temp, wbSrc
Dim objShell, fol, strFileName, strDirectory, extension, Filename
Dim objFSO, objFolder, objFile
strFileName = "C:\Users\ARUN\Desktop\LD.xlsx"
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWorkbook = objExcel.Workbooks.Add()
extension = "xlsx"
strDirectory = InputBox("Enter the Folder Path:","Folder Path")
'strDirectory = "C:\Users\ARUN\Desktop\Excel Merger Project"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strDirectory)
'For loop to count the number of files starts
For Each objFile In objFolder.Files
if LCase((objFSO.GetExtensionName(objFile))) = LCase(extension) then
counter = counter + 1
'Get the file name
FileName = objFile.Name
'Temp = msgbox(FileName,0,"File Name" )
end if
Next
'For loop to count the number of files ends
Temp = "There are " & counter & " '. " & extension & "' files in the " & strDirectory & " folder path."
Set objShell = Wscript.CreateObject("Wscript.Shell")
objShell.Popup Temp,2,"Files Count"
For Each objFile In objFolder.Files
If LCase((objFSO.GetExtensionName(objFile))) = LCase(extension) Then
Filename = objFile.Name
Filename = strDirectory & "\" & Filename
Set wbSrc = objExcel.Workbooks.Open(Filename)
wbSrc.Sheets(1).Copy objWorkbook.Sheets(objWorkbook.Sheets.Count)
wbSrc.Close
End If
Next
objWorkbook.sheets("Sheet1").Delete
objWorkbook.sheets("Sheet2").Delete
objWorkbook.sheets("Sheet3").Delete
'~~> Close and Cleanup
objWorkbook.SaveAs (strFileName)
objWorkbook.Close
objExcel.Quit
objShell.Popup "All The Files Are Merged!!!",2,"Success"
Set fol = objFSO.GetFolder(strDirectory)
FolderName = InputBox("Enter the Folder Path:","Folder Path")
FolderNameMove = FolderName & "\"
objFSO.CopyFile strFileName, FolderNameMove
Like I said, I am not sure what could be the reason as you are not getting an error. Possibly a memory issue? However as I suggested in comments above, you can copy the cells across as mentioned in this LINK Way 2
Also like I mentioned, it is not necessary that the the new workbook that is created will have 3 sheets. It all depends on the Excel settings. If you see Excel Options, you will notice that the default setting is 3
What if a user has set it to 2? Then your code
objWorkbook.sheets("Sheet1").Delete
objWorkbook.sheets("Sheet2").Delete
objWorkbook.sheets("Sheet3").Delete
will fail on the 3rd line as there is no sheet by that name. Also under different, regional settings, the names of the sheet might not be Sheet1, Sheet2 or Sheet3. We might be tempted to use On Error Resume Next to delete the sheets. For example
On Error Resume Next
objWorkbook.sheets("Sheet1").Delete
objWorkbook.sheets("Sheet2").Delete
objWorkbook.sheets("Sheet3").Delete
On Error GoTo 0
or
On Error Resume Next
objWorkbook.sheets(1).Delete
objWorkbook.sheets(2).Delete
objWorkbook.sheets(3).Delete
On Error GoTo 0
This will work but then what if the default setting is 5. What happens to the additional 2 sheets. So the best approach is
To delete all sheets except 1 sheet as Excel will not let you delete that
Add new sheets. The trick here is that you add all the new sheets to the end
Once you are done, simply delete the 1st sheet.
Try this (TRIED AND TESTED)
Dim objExcel, objWorkbook, wbSrc, wsNew
Dim strFileName, strDirectory, extension, FileName
Dim objFSO, objFolder, objFile
strFileName = "C:\Users\Siddharth Rout\Desktop\LD.xlsx"
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWorkbook = objExcel.Workbooks.Add()
'~~> This will delete all sheets except the first sheet
'~~> We can delete this sheet at the end.
objExcel.DisplayAlerts = False
On Error Resume Next
For Each ws In objWorkbook.Worksheets
ws.Delete
Next
On Error GoTo 0
objExcel.DisplayAlerts = True
extension = "xlsx"
strDirectory = "C:\Users\Siddharth Rout\Desktop\Excel Merger Project"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strDirectory)
For Each objFile In objFolder.Files
If LCase((objFSO.GetExtensionName(objFile))) = LCase(extension) Then
FileName = objFile.Name
FileName = strDirectory & "\" & FileName
Set wbSrc = objExcel.Workbooks.Open(FileName)
'~~> Add the new worksheet at the end
Set wsNew = objWorkbook.Sheets.Add(, objWorkbook.Sheets(objWorkbook.Sheets.Count))
wbSrc.Sheets(1).Cells.Copy wsNew.Cells
wbSrc.Close
End If
Next
'~~> Since all worksheets were added in the end, we can delete sheet(1)
'~~> We still use On error resume next becuase what if no sheets were added.
objExcel.DisplayAlerts = False
On Error Resume Next
objWorkbook.Sheets(1).Delete
On Error GoTo 0
objExcel.DisplayAlerts = True
'~~> Close and Cleanup
objWorkbook.SaveAs (strFileName)
objWorkbook.Close
objExcel.Quit
Set wsNew = Nothing
Set wbSrc = Nothing
Set objWorkbook = Nothing
Set objExcel = Nothing