I'm looking for VBS that can automatically combine all columns to single one, table to column...appreciate for your support.
ROW1| A D G
ROW2| B E H
ROW3| C F I
Expected result:
A
B
C
D
E
F
G
H
I
You could start with something like this:
Option Explicit
'Var's Used
Dim oXLApp, oSheet, sXlFile, sWorkSheet, iStartRow, iEndRow
Dim iStartColumn, iEndColumn, iRowIndex, iColIndex, sValue
'Set file path and name to excel file that contains the data
sXlFile = "E:\Sample.xls"
sWorkSheet = "Sheet1"
'Set the start & end rows and columns
iStartRow = 1
iEndRow = 3
iStartColumn = 1
iEndColumn = 3
'Create the excel object
Set oXLApp = CreateObject("Excel.Application")
'Make it visible
oXLApp.Visible = True
'Open the workbook
oXLApp.Workbooks.Open(sXlFile)
'Create the worksheet object
Set oSheet = oXLApp.Sheets(sWorkSheet)
'Row loop
For iRowIndex = iStartRow To iEndRow
'Column loop
For iColIndex = iStartColumn To iEndColumn
'Get the Value of the cell
sValue = oSheet.Cells(iRowIndex,iColIndex).Value
'So something with the value
WScript.Echo sValue
Next
Next
'Distroy the sheet object
Set oSheet = Nothing
'Close the workbook
oXLApp.Workbooks.Close
'Exit Excel
oXLApp.Quit
'Distroy the XLApp object
Set oXLApp = Nothing
Related
Kind of new to VBS. I'm trying to count the fields in the file and have this code.
Col()
Function Col()
Const FSpec = "C:\test.txt"
Const del = ","
dim fs : Set fs = CreateObject("Scripting.FileSystemObject")
dim f : Set f = fs.OpenTextFile(FSpec, 1)
Dim L, C
Do Until f.AtEndOfStream
L = f.ReadLine()
C = UBound(Split(L, del))
C = C +1
WScript.Echo "Items:", C
Loop
f.Close
End Function
It works however, I don't want to count the delim inside " ".
Here's file content:
1,"2,999",3
So basically, I'm getting 4 items for now but I wanted to get 3. Kind of stuck here.
For an example of my second suggestion, a very simple example could be something like this. Not saying it is perfect, but it illustrates the idea:
Dim WeAreInsideQuotes 'global flag
Function RemoveQuotedCommas(ByVal line)
Dim i
Dim result
Dim current
For i = 1 To Len(line)
current = Mid(line, i, 1) 'examine character
'check if we encountered a quote
If current = Chr(34) Then
WeAreInsideQuotes = Not WeAreInsideQuotes 'toggle flag
End If
'process the character
If Not (current = Chr(44) And WeAreInsideQuotes) Then 'skip if comma and insode quotes
result = result & current
End If
Next
RemoveQuotedCommas = result
End Function
I am trying to write a function which will delete all sheets except the one passed as parameter. Below function is being called but function does not delete any sheets. How can I delete all worksheets except one?
........
Set ExcelObj = createobject("excel.application")
ExcelObj.Visible = true
Set ConfigFile = ExcelObj.Workbooks.Open (FilePath)
Set ConfigSheet = ConfigFile.Worksheets("Scripts")
Set ConfigApplicationSheet = ConfigFile.Worksheets("Applications")
Set ExecutiveSummarySheet = ConfigFile.Worksheets("Summary")
ExcelObj.ActiveWorkBook.SaveAs SummaryFilePath
DeleteSheet "ConfigScripSheet","Summary"
Function DeleteSheet(ConfigSheet,mySheetname)
'Writing Name and Path of each File to Output File
For Each ObjFile In ObjFiles
ObjOutFile.WriteLine(ObjFile.Name & String(50 - Len(ObjFile.Name), " ") & ObjFile.Path)
Next
ObjOutFile.Close
DeleteSheet = 0
ExcelObj.DisplayAlerts = False
For Each objWorksheet In ConfigSheet.Worksheets
If not objWorksheet.Name = mySheetname Then
DeleteSheet = 1
ConfigScripSheet.sheets(objWorksheet.Name).Select
ConfigScripSheet.sheets(objWorksheet.Name).Delete
ExcelObj.DisplayAlerts = False
End If
Next
End Function
Trying to correct your code above was too much of a minefield for me as I couldn't tell what you meant in several places - so I rewrote it based on what you had said in the description was your goal.
The code below will open the file, associate the objects the way you had them, pass the workbook object and a sheet name not to be deleted into the DeleteSheet function, which will delete any sheet in the workbook that is not named as per the passed in parameter SheetNameNotToDelete
Let me know if any of the code is unclear.
Option Explicit ' Forces declaration of variables
Dim FilePath, SummaryFilePath '<-- Need set to some value!
FilePath = ""
SummaryFilePath = ""
Dim ExcelObj : Set ExcelObj = CreateObject("Excel.Application")
Dim ConfigFile : Set ConfigFile = ExcelObj.Workbooks.Open(FilePath)
Dim ConfigSheet : Set ConfigSheet = ConfigFile.Worksheets("Scripts")
Dim ConfigApplicationSheet : Set ConfigApplicationSheet = ConfigFile.Worksheets("Applications")
Dim ExecutiveSummarySheet : Set ExecutiveSummarySheet = ConfigFile.Worksheets("Summary")
ExcelObj.ThisWorkbook.SaveAs SummaryFilePath
DeleteSheet ConfigFile, "Summary"
Function DeleteSheet(ByRef WorkbookObj, ByVal SheetNameNotToDelete)
Dim oWorksheet
For Each oWorksheet In WorkbookObj.Worksheets
If oWorksheet.Name <> SheetNameNotToDelete And WorkbookObj.Worksheets.Count >=2 Then
oWorksheet.Delete ' Excel won't let you delete all worksheets from a workbook
End If ' the check on Count >=2 covers the case where no worksheet exists
Next ' called "Summary" to be left
End Function
I would like to have a script that reads a specific folder and extracts the base file names, removes the last two characters and then uses the result to populate the text of an inputbox. The user then selects from the given options and the remainder of the script searches and replaces text in a second folder with the selected text.
Example file names in the initial target folder:
ABFA1
ABFA3
ABFA4
HVA1
HVA3
HVA4
ITALA1
ITALA3
ITALA4
Obviously, once the last 2 characters are removed, I am left with duplicates which I will need to remove.
Here is part of the script I have so far:
Set objFSO = CreateObject("Scripting.FileSystemObject")
strFilePath = objFSO.BuildPath(objFSO.GetAbsolutePathName("."), "\dwgs\logos")
If Not objFSO.FolderExists(strFilePath) Then
wscript.echo("Folder does not exist, script exiting")
wscript.quit
End if
'
Set objFolder = objFSO.GetFolder (strFilePath)
For Each objFile In objFolder.Files
strFile = objFSO.GetBaseName(objFile.Name)
strFile = LEFT(strFile, (LEN(strFile)-2))
' wscript.echo(strFile)
Next
'delete all duplicate files names and add result to dictionary (or array?)
'create an inputbox and present a number of choices populated by the dictionary/array
user1 = InputBox("Select a Logo:"&(chr(13))&(chr(13))&(*array/dict*)), "Logo Replacement Script")
' Set arguments
strFilePath2 = objFSO.BuildPath(objFSO.GetAbsolutePathName("."), "\dwgs")
FindString = "dwgs\logos\"
ReplaceStringWith = "dwgs\logos\"&(user1)
' Find and replace function
I am able to get the base file names with the last 2 characters removed, but I dont know how to weed out the duplicates and then use the result in an inputbox? (I'm imagining text within the inputbox of a number followed by a choice and the user enters the number to signify which option to use)
My first thought was to use an array, but after some reading, it would seem a dictionary approach might be better. Unfortunately, I haven't been able to figure out how to incorporate it into the script.
Any help would be much appreciated.
Updated script incorporating input from Ekkehard:
Set objFSO = CreateObject("Scripting.FileSystemObject")
strFilePath = objFSO.BuildPath(objFSO.GetAbsolutePathName("."), "\dwgs\logos")
'
Function ShowFilesInFolder(strFolderPath)
Set oFolder = objFSO.GetFolder(strFolderPath)
Set oFileCollection = oFolder.Files
For Each oTempFile in oFileCollection
strTemp = strTemp & oTempFile.name
strTemp = LEFT(strTemp, (LEN(strTemp)-6))
Next
ShowFilesInFolder = strTemp
End Function
x = ShowFilesInFolder(strFilePath)
'
Function mkDic(aK, aV)
Dim tmp : Set tmp = CreateObject("Scripting.Dictionary")
Dim i
For i = 0 To UBound(aK)
tmp(aK(i)) = aV(i)
Next
Set mkDic = tmp
End Function
'
Dim a : a = Split (x)
WScript.Echo Join(mkDic(a, a).Keys)
For some reason I cant get the mkDic Function to split the input from the ShowFilesInFolder Function?
Is there an easier way to go about it than what I have come up with?
The VBScript tool for uniqueness is The Dictionary. This demo (cf. here)
Option Explicit
' based on an Array 2 Dictionary function from
' !! https://stackoverflow.com/a/45554988/603855
Function mkDic(aK, aV)
Dim tmp : Set tmp = CreateObject("Scripting.Dictionary")
Dim i
For i = 0 To UBound(aK)
' tmp(aK(i)) = aV(i)
tmp(Mid(aK(i), 1, Len(aK(i)) - 2)) = aV(i)
Next
Set mkDic = tmp
End Function
Dim a : a = Split("ABFA1 ABFA3 ABFA4 HVA1 HVA3 HVA4 ITALA1 ITALA3 ITALA4")
WScript.Echo Join(a)
WScript.Echo Join(mkDic(a, a).Keys), "=>", Join(mkDic(a, a).Items)
output:
cscript 45590698.vbs
ABFA1 ABFA3 ABFA4 HVA1 HVA3 HVA4 ITALA1 ITALA3 ITALA4
ABF HV ITAL => ABFA4 HVA4 ITALA4
shows, how to de-duplicate an array and how to stringify the (unique) keys for concatenating into a prompt.
I managed to get a working script, but couldn't figure out how to do it without using a couple of temporary text files to pass the data on.
I thought I would post the code in case it may be of help to someone.
Const ForReading = 1, ForWriting = 2, ForAppending = 8, N = 0
Set fso = CreateObject("Scripting.FileSystemObject")
strFilePath = fso.BuildPath(fso.GetAbsolutePathName("."), "\dwgs\logos")
If Not fso.FolderExists(strFilePath) Then
wscript.echo("The LOGO Folder Does Not Exist - Exiting Script")
wscript.quit
End if
'
Set f = fso.OpenTextFile("xtempLogos.txt", ForWriting, True)
Set objShell = CreateObject ("Shell.Application")
Set objFolder = objShell.Namespace (strFilePath)
For Each strFileName in objFolder.Items
a = objFolder.GetDetailsOf (strFileName, N)
a = LEFT(a, (LEN(a)-6))
f.Writeline (a)
Next
f.Close
'
Set f = fso.OpenTextFile("xtempLogos.txt", ForReading)
TheFile = f.ReadAll
f.Close
'
Function mkDic(aK, aV)
Dim tmp : Set tmp = CreateObject("Scripting.Dictionary")
Dim i
For i = 0 To UBound(aK)
tmp(aK(i)) = aV(i)
Next
Set mkDic = tmp
End Function
'
Set f = fso.OpenTextFile("xtempLogos.txt", ForWriting, True)
Dim a : a = Split(TheFile,vbcrlf)
a = Join(mkDic(a, a).Keys)
f.Writeline (a)
f.Close
'
Set f = fso.OpenTextFile("xtempLogos2.txt", ForWriting, True)
Set f = fso.OpenTextFile("xtempLogos.txt", ForReading)
theFile = f.ReadAll
number = 1
myArray = Split(theFile)
for i = 0 to Ubound(MyArray)-1
Set f = fso.OpenTextFile("xtempLogos2.txt", ForAppending, True)
If number < 10 then f.Writeline (number) & ".........." & myArray(i)
If number >=10 then f.Writeline (number) & "........." & myArray(i)
f.Writeline ""
Set f = fso.OpenTextFile("xtempLogos.txt", ForReading, True)
number=number+1
Next
f.Close
'
Set f = fso.OpenTextFile("xtempLogos2.txt", ForReading)
TheFile = f.ReadAll
f.Close
'
user1 = InputBox("WHICH LOGO DO YOU WANT TO ADD?"&(chr(13))&(chr(13))&(chr(13))& (theFile), "Add Logo Script", 11)
choice = (user1) - 1
wscript.echo myArray(choice)
'
Set f = fso.GetFile("xtempLogos.txt")
f.Delete
Set f = fso.GetFile("xtempLogos2.txt")
f.Delete
This is my script which opens Excel files and takes info from some cells then inserts it in another Excel document. I have included the entire script but marked where I think the error is. I am really confused at why this isn't working as I am using the exact same method in another script that works perfectly.
updated code from answers, same problem remains.
I think it's being caused by the Find_Excel_Row.
I tried putting the script in the function in the loop so there was no problem with variables but I got the same error.
Dim FSO 'File system Object
Dim folderName 'Folder Name
Dim FullPath 'FullPath
Dim TFolder 'Target folder name
Dim TFile 'Target file name
Dim TFileC 'Target file count
Dim oExcel 'The Excel Object
Dim oBook1 'The Excel Spreadsheet object
Dim oBook2
Dim oSheet 'The Excel sheet object
Dim StrXLfile 'Excel file for recording results
Dim bXLReadOnly 'True if the Excel spreadsheet has opened read-only
Dim strSheet1 'The name of the first Excel sheet
Dim r, c 'row, column for spreadsheet
Dim bFilled 'True if Excel cell is not empty
Dim iRow1 'the row with lower number in Excel binary search
Dim iRow2 'the row with higher number in Excel binary search
Dim iNumpasses 'Number of times through the loop in Excel search
Dim Stock 'product stock levels
Dim ID 'product ID
Dim Target 'Target file
Dim Cx 'Counter
Dim Cxx 'Counter 2
Dim RR, WR 'Read and Write Row
Call Init
Sub Init
Set FSO = CreateObject("Scripting.FileSystemObject")
FullPath = FSO.GetAbsolutePathName(folderName)
Set oExcel = CreateObject("Excel.Application")
Target2 = CStr("D:\Extractor\Results\Data.xls")
Set oBook2 = oExcel.Workbooks.Open(Target2)
TFolder = InputBox ("Target folder")
TFile = InputBox ("Target file")
TFileC = InputBox ("Target file count")
Call Read_Write
End Sub
Sub Read_Write
RR = 6
PC = 25
For Cx = 1 to Cint(TFileC)
Target = CStr("D:\Extractor\Results\"& TFolder & "\"& TFile & Cx &".html")
For Cxx = 1 to PC
Call Find_Excel_Row
Set oBook1 = oExcel.Workbooks.Open(Target)
Set Stock = oExcel.Cells(RR,5)
Set ID = oExcel.Cells(RR,3)
MsgBox ( Cxx &"/25 " &" RR: "& RR & " ID: " & ID & " Stock: " & Stock )
oBook1.Close
MsgBox "Writing Table"
oExcel.Cells(r,4).value = Stock '<<< Area of issue
oExcel.Cells(r,2).value = ID '<<<
oBook2.Save
oBook2.Close
Cxx = Cxx + 1
RR = RR + 1
Next
Cx = Cx + 1
Next
MsgBox "End"
oExcel.Quit
End sub
Sub Find_Excel_Row
bfilled = False
iNumPasses = 0
c = 1
iRow1 = 2
iRow2 = 10000
Set oSheet = oBook2.Worksheets.Item("Sheet1")
'binary search between iRow1 and iRow2
Do While (((irow2 - irow1)>3) And (iNumPasses < 16))
'Set current row
r = Round(((iRow1 + iRow2) / 2),0)
'Find out if the current row is blank
If oSheet.Cells(r,c).Value = "" Then
iRow2 = r + 1
Else
iRow1 = r - 1
End If
iNumPasses = iNumPasses + 1
Loop
r = r + 1
'Step search beyond the point found above
While bFilled = False
If oSheet.Cells(r,c).Value = "" Then
bFilled = True
Else
r = r + 1
End If
Wend
oExcel.Workbooks.Close
End Sub
In addition to what #Ekkehard.Horner said, you can't use the Excel object after quitting, so you should be getting an error when trying to open Data.xls.
oExcel.Workbooks.Close
oExcel.Quit
'writes to Graph sheet
set oBook = oExcel.Workbooks.Open("D:\Extractor\Results\Data.xls")
' ^^^^^^ This should be giving you an error
'Writing Table
MsgBox "Writing Table"
oExcel.Cells(r,4).value = Stock <<< Error here
oExcel.Cells(r,2).value = ID <<<
In fact, you're closing the application at several points in your script. Don't do that. Create the Excel instance once, use this one instance throughout your entire script, and terminate it when your script ends.
Edit: This is what causes your issue:
Set Stock = oExcel.Cells(RR,5)
Set ID = oExcel.Cells(RR,3)
...
oBook1.Close
...
oExcel.Cells(r,4).value = Stock '<<< Area of issue
oExcel.Cells(r,2).value = ID '<<<
You assign Range objects (returned by the Cells property) to the variables Stock and ID, but then close the workbook with the data these objects reference.
Since you want to transfer values anyway, assign the value of the respective cells to the variables Stock and ID:
Stock = oExcel.Cells(RR,5).Value
ID = oExcel.Cells(RR,3).Value
Also, I'd recommend to avoid using the Cells property of the application object. Instead use the respective property of the actual worksheet containing the data so it becomes more obvious what you're referring to:
Stock = oBook1.Sheets(1).Cells(RR,5).Value
ID = oBook1.Sheets(1).Cells(RR,5).Value
After you fixed that you'll most likely run into the next issue with the following lines:
oBook2.Save
oBook2.Close
You're closing oBook2 inside a loop without exiting from the loop. That should raise an error in the next iteration (when you try to assign the next values to the already closed workbook). Move the above two statements outside the loop or, better yet, move them to the Init procedure (after the Call Read_Write statement). From a handling perspective it's best to close/discard objects in the same context in which they were created (if possible). Helps avoiding attempts to use objects before they were created or after they were destroyed.
To further optimize your script you could even avoid the intermediate variables Stock and ID and transfer the values directly:
oBook2.Sheets(1).Cells(r,4).value = oBook1.Sheets(1).Cells(RR,5).Value
oBook2.Sheets(1).Cells(r,2).value = oBook1.Sheets(1).Cells(RR,5).Value
Re-using the same loop control variable (count) in nested loops is illegal:
Option Explicit
Dim bad_loop_counter
For bad_loop_counter = 1 To 2
WScript.Echo "outer", bad_loop_counter
For bad_loop_counter = 1 To 2
WScript.Echo "inner", bad_loop_counter
Next
Next
output:
cscript 32246593.vbs
... 32246593.vbs(6, 26) Microsoft VBScript compilation error: Invalid 'for' loop control variable
So your code won't even compile.
I am failrly new to VBScript, I want to copy a particular column (say Column C) from multiple excel sheets (Source_1.xlsx, Source_2.xlsx, and Source_3.xlsx). and paste it to Column A of another excel sheet Dest.xlsx. This column should be free from duplicate values. Any help would be appreciated.
Firstly you need to create the excel object, assuming the files are the same, and you use an increasing integer at the end, you can iterate through each excel object. as you iterate through, you can call upon the same column as a const, and copy to a new filename. When you start to have some code, report back and it can be worked on further
for i to x
filename = "scen_"& i & ".xlsx"
copyfilename = "copytohere.xlsx"
'set up the object
for rowstart to rowend
'get contents of x column
'copy contents to copyfilename excel doc
Loop
loop
Thanks
Const xlFilterCopy = 2
Const xlUp = -4162
Const xlDown = -4121
strPathSrc = "C:\Test" ' Source files folder
strMaskSrc = "Source_*.xlsx" ' Source files filter mask
iSheetSrc = 1 ' Sourse sheet index or name
iColSrc = 3 ' Source column index, e. g. 3 for "C"
strPathDst = "C:\Test\Dest.xlsx" ' Destination file
iColDst = 1 ' Destination column index
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWorkBookDst = objExcel.Workbooks.Open(strPathDst)
Set objSheetTmp = objWorkBookDst.Worksheets.Add
objSheetTmp.Cells(1, iColDst).Value = "TempHeader"
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)
objSheetSrc.Cells(1, iColSrc).Insert xlDown
objSheetSrc.Cells(1, iColSrc).Value = "TempHeader"
Set objRangeSrc = GetRange(iColSrc, objSheetSrc)
If objRangeSrc.Cells.Count > 1 then
nNextRow = GetRange(iColDst, objSheetTmp).Rows.Count + 1
objRangeSrc.AdvancedFilter xlFilterCopy, , objSheetTmp.Cells(nNextRow, iColDst), True
objSheetTmp.Cells(nNextRow, iColDst).Delete xlUp
Set objRangeTmp = GetRange(iColDst, objSheetTmp)
Set objSheetDst = objWorkBookDst.Worksheets.Add
objRangeTmp.AdvancedFilter xlFilterCopy, , objSheetDst.Cells(1, iColDst), True
objSheetTmp.Delete
Set objSheetTmp = objSheetDst
End If
objWorkBookSrc.Close
Next
objSheetTmp.Cells(1, iColDst).Delete xlUp
objExcel.DisplayAlerts = True
Function GetRange(iColumn, objSheet)
With objSheet
Set GetRange = .Range(.Cells(1, iColumn), .Cells(.Cells(.Cells.Rows.Count, iColumn).End(xlUp).Row, iColumn))
End With
End Function