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
Related
I have written a macro, that is crawling through multiple excel files, which are all identical in terms of structure (columns, but row content may differ; there is a "key" though) and matching and copying the data into a master file. But with an increasing number of files the duration of macro execution is growing longer and longer, so maybe someone has a more efficient solution available?
Sub DataCrawler()
On Error GoTo HandleError
Application.ScreenUpdating = False
Dim objectFileSys As Object
Dim objectGetFolder As Object
Dim file As Object
Set objectFileSys = CreateObject("Scripting.FileSystemObject")
Set objectGetFolder = objectFileSys.GetFolder("pathName") ' location of folder with files
Dim counter As Integer
counter = 0
' macro opens one file after another and checks for every key, if data is available
For Each file In objectGetFolder.Files
Dim sourceFiles As Workbook
Set sourceFiles = Workbooks.Open(file.Path, True, True)
Dim lookUp As Range
Dim searchRange As Range
For i = 10 To 342 ' number of rows with key in master file
Set lookUp = Cells(i, 31)
Set searchRange = sourceFiles.Worksheets("tableName").Range("AE:AJ")
' if cell in master file related to the key is empty, copy data
If IsEmpty(Cells(i, 35)) Then
lookUp.Offset(0, 1).Value = Application.VLookup(lookUp, searchRange, 2, False)
lookUp.Offset(0, 2).Value = Application.VLookup(lookUp, searchRange, 3, False)
lookUp.Offset(0, 3).Value = Application.VLookup(lookUp, searchRange, 4, False)
lookUp.Offset(0, 4).Value = Application.VLookup(lookUp, searchRange, 5, False)
lookUp.Offset(0, 5).Value = Application.VLookup(lookUp, searchRange, 6, False)
' if cell in master file related to the key is already filled, skip
Else
End If
Next
sourceFiles.Close False
Set sourceFiles = Nothing
Next
HandleError:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
A single Application.Match() to find the row for the "key", then copying the content as an array would be faster, but it's difficult to say what impact that would have on the overall run time. That would depend on how many files you're opening, and what the performance of that aspect of the process is like.
Sub DataCrawler()
Dim objectFileSys As Object, objectGetFolder As Object
Dim file As Object, searchRange As Range, i As Long
Dim m, wsData As Worksheet, wbSource As Workbook
On Error GoTo HandleError
Application.ScreenUpdating = False
Application.EnableEvents = False
Set wsData = ThisWorkbook.Sheets("Lookup") 'for example
Set objectFileSys = CreateObject("Scripting.FileSystemObject")
Set objectGetFolder = objectFileSys.GetFolder("pathName")
For Each file In objectGetFolder.Files
Set wbSource = Workbooks.Open(file.Path, True, True)
Set searchRange = wbSource.Worksheets("tableName").Columns("AE")
For i = 10 To 342 ' number of rows with key in master file
If IsEmpty(wsData.Cells(i, 35)) Then
m = Application.Match(wsData.Cells(i, 31).Value, searchRange, 0)
If Not IsError(m) Then
wsData.Cells(i, 32).Resize(1, 5).Value = _
searchRange.Cells(m).Offset(0, 1).Resize(1, 5).Value
End If
End If
Next
wbSource.Close False
Next file
HandleError:
If Err.Number <> 0 Then MsgBox Err.Description
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I have a daily dump of 2 different text files (in the same folder) that get overwritten daily. I would like to be able to import them into an active spreadsheet with tab delimited, at the same time with a VBA code. I would really appreciate the help!
I am using excel 2016. My manual import method of 1 of the text file when recorded gives this code which is how i would like BOTH the text files to be imported (formatting preserved):
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;C:\Users\Mr D\Music\New folder\B.txt", Destination:=Range("$A$1"))
.CommandType = 0
.Name = "B"
.FieldNames = True
.RowNumbers =enter code here False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 1252
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub
The code that i have tried using is from other similar questions posted here does not seem to work:
Sub ReadFilesIntoActiveSheet()
Dim fso As FileSystemObject
Dim folder As folder
Dim file As file
Dim FileText As TextStream
Dim TextLine As String
Dim Items() As String
Dim i As Long
Dim cl As Range
' Get a FileSystem object
Set fso = New FileSystemObject
' get the directory you want
Set folder = fso.GetFolder("C:\Users\Mr D\Music\")
' set the starting point to write the data to
Set cl = ActiveSheet.Cells(1, 1)
' Loop thru all files in the folder
For Each file In folder.Files
' Open the file
Set FileText = file.OpenAsTextStream(ForReading)
' Read the file one line at a time
Do While Not FileText.AtEndOfStream
TextLine = FileText.ReadLine
' Parse the line into | delimited pieces
Items = Split(TextLine, "|")
' Put data on one row in active sheet
For i = 0 To UBound(Items)
cl.Offset(0, i).Value = Items(i)
Next
' Move to next row
Set cl = cl.Offset(1, 0)
Loop
' Clean up
FileText.Close
Next file
Set FileText = Nothing
Set file = Nothing
Set folder = Nothing
Set fso = Nothing
End Sub
do like this if your text files is with tab delimited.
Sub ReadFilesIntoActiveSheet()
Dim fso As FileSystemObject
Dim folder As folder
Dim file As file
Dim FileText As TextStream
Dim TextLine As String
Dim Items() As String
Dim i As Long
Dim cl As Range
Dim sFolder As String, vDB, Ws As Worksheet
Dim rngT As Range
' Get a FileSystem object
Set fso = New FileSystemObject
' get the directory you want
sFolder = "C:\Users\Mr D\Music\"
Set folder = fso.GetFolder(sFolder)
' set the starting point to write the data to
Set Ws = ActiveSheet
'Set cl = ActiveSheet.Cells(1, 1)
' Loop thru all files in the folder
For Each file In folder.Files
Workbooks.Open Filename:=sFolder & file.Name, Format:=1
With ActiveWorkbook.ActiveSheet
vDB = .UsedRange
End With
ActiveWorkbook.Close
Set rngT = Ws.Range("a" & Rows.Count).End(xlUp)(2)
rngT.Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB
Next file
Ws.Range("a1").EntireRow.Delete
Set FileText = Nothing
Set file = Nothing
Set folder = Nothing
Set fso = Nothing
End Sub
From the second text file, the header will be ignored.
Sub ReadFilesIntoActiveSheet()
Dim fso As FileSystemObject
Dim folder As folder
Dim file As file
Dim FileText As TextStream
Dim TextLine As String
Dim Items() As String
Dim i As Long
Dim cl As Range
Dim sFolder As String, vDB, Ws As Worksheet
Dim rngT As Range
' Get a FileSystem object
Set fso = New FileSystemObject
' get the directory you want
sFolder = "C:\Users\Mr D\Music\"
Set folder = fso.GetFolder(sFolder)
' set the starting point to write the data to
Set Ws = ActiveSheet
'Set cl = ActiveSheet.Cells(1, 1)
Ws.Cells.Clear
' Loop thru all files in the folder
For Each file In folder.Files
i = i + 1
Workbooks.Open Filename:=sFolder & file.Name, Format:=1
With ActiveWorkbook.ActiveSheet
If i = 1 Then
vDB = .UsedRange
Else
vDB = .UsedRange.Offset(1)
End If
End With
ActiveWorkbook.Close
Set rngT = Ws.Range("a" & Rows.Count).End(xlUp)(2)
rngT.Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB
Next file
Ws.Range("a1").EntireRow.Delete
Set FileText = Nothing
Set file = Nothing
Set folder = Nothing
Set fso = Nothing
End Sub
We want to compare the output of the first column in two different Excel sheets and update the differences to a text file. This is comparing only A1 data in excel1 with A1 data of excel2 and appending to the text file:
Dim objExcel,ObjWorkbook,objsheet,ObjWorkbook1,objsheet1,Originalvalue,filesys, filetxt
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("D:\Test\copy.xlsx")
set objsheet = objExcel.ActiveWorkbook.Worksheets(1)
Set objWorkbook1 = objExcel.Workbooks.Open("D:\Test\Original.xlsx")
set objsheet1 = objExcel.ActiveWorkbook.Worksheets(1)
Originalvalue = objsheet.Cells(1,1).value
Copyvalue = objsheet1.Cells(1,1).value
If Originalvalue = Copyvalue then
Set filesys = CreateObject("Scripting.FileSystemObject")
Set filetxt = filesys.OpenTextFile("D:\Test\output.txt", ForAppending, True)
filetxt.WriteLine(Originalvalue)
filetxt.Close
msgbox Originalvalue
else
Set filesys = CreateObject("Scripting.FileSystemObject")
Set filetxt = filesys.OpenTextFile("D:\Test\output.txt", ForAppending, True)
filetxt.WriteLine(Copyvalue)
filetxt.Close
msgbox Copyvalue
End If
objExcel.ActiveWorkbook.Close
objExcel.Workbooks.Close
objExcel.Application.Quit
How can this be done for all the data in the A column please?
This compares the files and if there is a different value in the copy file it is placed into the text file..if the values are equal, they are ignored..not sure if thats the behavior you are looking for, but you can at least see how to loop through the files to compare all the records
Dim objExcel, ObjWorkbook, objsheet, ObjWorkbook1, objsheet1, Originalvalue, filesys, filetxt
Dim objsheet_LastRow As Long, objsheet1_LastRow, LastRow As Long, RowCounter As Long, CopyValue
Const ForReading = 1, ForWriting = 2, ForAppending = 8
'are you doing this because you are running this outside of excel?
'if not then this doesn't have to look as complicated as it is
Set objExcel = CreateObject("Excel.Application")
Set ObjWorkbook = objExcel.Workbooks.Open("D:\Test\copy.xlsx")
Set objsheet = objExcel.ActiveWorkbook.Worksheets(1)
Set ObjWorkbook1 = objExcel.Workbooks.Open("D:\Test\Original.xlsx")
Set objsheet1 = objExcel.ActiveWorkbook.Worksheets(1)
Set filesys = CreateObject("Scripting.FileSystemObject")
Set filetxt = filesys.OpenTextFile("D:\Test\output.txt", ForAppending, True)
'find the last row of data in each sheet, this will only go the end of the shorter file
objsheet_LastRow = objsheet.Cells(100000, 1).End(xlUp).Row
objsheet1_LastRow = objsheet1.Cells(100000, 1).End(xlUp).Row
LastRow = Application.WorksheetFunction.Min(objsheet_LastRow, objsheet1_LastRow)
For RowCounter = 1 To LastRow
Originalvalue = objsheet.Cells(RowCounter, 1).Value
CopyValue = objsheet1.Cells(RowCounter, 1).Value
'if values are different, put the new value in a txt file
If Originalvalue <> CopyValue Then filetxt.WriteLine (CopyValue)
Next RowCounter
filetxt.Close
ObjWorkbook.Close False
ObjWorkbook1.Close False
'objExcel.ActiveWorkbook.Close
'objExcel.Workbooks.Close
objExcel.Application.Quit
TODO: error trapping
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
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)