Visual Studio 2015 - Manipulating Excel? - vb.net

I have 750 Excel files that I want to
clean by deleting columns of data that have a heading with an asterisk,
then take some of that data and put it in a new workbook worksheet, and other data into the same workbook worksheet, and some other data into a second new workbook.
I created a WPF project in Visual Studio 2015 with a little dialog box with 2 radio buttons for
clean data,
produce new files.
This is my VB code:
Class MainWindow
Dim wb As Microsoft.Office.Interop.Excel._Workbook
Dim ws As Microsoft.Office.Interop.Excel._Worksheet
Dim iCol As Integer
Dim strName As String
Dim iIndex As Integer
Dim strPath As String
Dim strFile As String
Private Sub button_Click(sender As Object, e As RoutedEventArgs) Handles button.Click
If cleanRadioButton.IsChecked = True Then
strPath = "c:\test\old\"
strFile = Dir(strPath & "*.csv")
Do While strFile <> ""
wb = wb.Open(Filename:=strPath & strFile)
'Loop through the sheets.
For iIndex = 1 To Application.Worksheets.Count
ws = Application.Worksheets(iIndex)
'Loop through the columns.
For iCol = 1 To ws.UsedRange.Columns.Count
'Check row 1 of this column for the char of *
If InStr(ws.Cells(10, iCol).Value, "*") > 0 Then
'We have found a column with the char of *
ws.Columns(iCol).EntireColumn.Delete
ws.Columns(iCol + 1).EntireColumn.Delete
ws.Columns(iCol + 2).EntireColumn.Delete
End If
Next iCol
Next iIndex
wb.SaveAs(Filename:="C:\test\new\" & wb.Name, FileFormat:=xlOpenXMLWorkbook)
wb.Close(SaveChanges:=False)
strFile = Dir()
Loop
MessageBox.Show("The csv files have now been cleaned. Congrats.")
Else inputRadioButton.IsChecked = True
MessageBox.Show("The data has now been split into Trajectory and ForcePlate input files. High 5.")
End If
End Sub
End Class
I get 3 errors but can't work out how to solve them.
a) Worksheets is not a member of Application [line 19]
b) Worksheets is not a member of Application [line 20]
c) 'xlOpenXMLWorkbook' is not declared. It may be inaccessible due to its protection level.

For a) and b), the pattern is :
Application.Workbooks.Worksheets
For c), easiest way out :
Go into VBE from Excel (Alt + F11)
Press F2 to display the Object Browser
Look for xlOpenXMLWorkbook
Result : Const xlOpenXMLWorkbook = 51 (&H33)
So, just replace it by the value 51!
Here is your amended code :
Class MainWindow
Dim wb As Microsoft.Office.Interop.Excel._Workbook
Dim ws As Microsoft.Office.Interop.Excel._Worksheet
Dim iCol As Integer
Dim strName As String
Dim iIndex As Integer
Dim wbIndex As Integer
Dim strPath As String
Dim strFile As String
Private Sub button_Click(sender As Object, e As RoutedEventArgs) Handles button.Click
If cleanRadioButton.IsChecked = True Then
strPath = "c:\test\old\"
strFile = Dir(strPath & "*.csv")
Do While strFile <> ""
wb = wb.Open(Filename:=strPath & strFile)
'Loop through the sheets.
For wbIndex = 1 To Application.Workbooks.Count
For iIndex = 1 To Application.Workbooks(wbIndex).Worksheets.Count
Ws = Application.Workbooks(wbIndex).Worksheets(iIndex)
'Loop through the columns.
For iCol = 1 To Ws.UsedRange.Columns.Count
'Check row 1 of this column for the char of *
If InStr(Ws.Cells(10, iCol).Value, "*") > 0 Then
'We have found a column with the char of *
Ws.Columns(iCol).EntireColumn.Delete
Ws.Columns(iCol + 1).EntireColumn.Delete
Ws.Columns(iCol + 2).EntireColumn.Delete
End If
Next iCol
Next iIndex
Next wbIndex
'Const xlOpenXMLWorkbook = 51 (&H33)
wb.SaveAs(Filename:="C:\test\new\" & wb.Name, FileFormat:=51)
wb.Close(SaveChanges:=False)
strFile = Dir()
Loop
MessageBox.Show ("The csv files have now been cleaned. Congrats.")
Else: inputRadioButton.IsChecked = True
MessageBox.Show ("The data has now been split into Trajectory and ForcePlate input files. High 5.")
End If
End Sub
End Class

To reference a worksheet yau can use either ws = wb.Worksheets(1) or ws = wb.Worksheets("Sheet1") or ws = excelApp.ActiveWorkbook.Worksheets(1) and to use xlOpenXMLWorkbook use the name of the corresponding Enum XlFileFormatas well: XlFileFormat.xlOpenXMLWorkbook.
This simplified example opens the workbook Test.xlsx, writes text in cell A1 and saves it to new folder.
Imports System.IO
Imports Microsoft.Office.Interop.Excel
Public Class MainWindow
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
Dim excelApp As Application
Dim wb As _Workbook
Dim ws As _Worksheet
Dim rng As Range
Dim strPathOld = "c:\temp\old"
Dim strPathNew = "c:\temp\new"
' get excel application reference
excelApp = New Application
excelApp.Visible = True
excelApp.ScreenUpdating = True
' open the workbook
wb = excelApp.Workbooks.Open(Path.Combine(strPathOld, "Test.xlsx"))
' set reference to the sheet with index 1
ws = wb.Worksheets(1)
' or use sheet name
' ws = wb.Worksheets("Sheet1")
' or use ActiveWorkbook if it exists
' ws = excelApp.ActiveWorkbook.Worksheets(1)
' write text in cell A1
rng = ws.Range("A1")
rng.Formula = "Test123"
' save the workbook in new location
wb.SaveAs(Filename:=Path.Combine(strPathNew, wb.Name), _
FileFormat:=XlFileFormat.xlOpenXMLWorkbook)
excelApp.Quit()
End Sub
End Class
Note: add reference to MS Office Interop for your version of Excel(here example for Excel 2007).

Related

VBA for copying multiple columns from different workbooks to be in columns next to each other

I am trying to pull data from a folder containing 300 Workbooks, each named 001, 002 etc.
I am only interested in pulling the data from column G of each file and copying it into a separate folder (each file does not have the same amount if data in row G)
I have been able to copy the data across, but I can't seem to get it to move past column 2 and instead writes over the previous column.
The output needed is:
data from column G workbook"001" pasted into "new sheet" column A
data from column G workbook"002" pasted into "new sheet" column B
and so on
Each file in the folder of 300 only has 1 worksheet each, each labelled: 001,002,...,300
This is the code I already had which results in 2 columns of data where 1 gets replaced by each new sheet instead.
Any help to solve this issue would be greatly appreciated.
Sub Copy()
Dim MyFile As String
Dim Filepath As String
Dim q As Long
Dim ThisCol As Integer
Dim ThisRow As Long
Dim CurS As Worksheet
Dim CurRg As Range
Dim InfCol As Integer
Set CurS = ActiveSheet
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
InfCol = 1
Filepath = "C:..."
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "Text to column.xlsm" Then
Exit Sub
End If
Workbooks.Open (Filepath & MyFile)
LastRow = Range("G1").CurrentRegion.Rows.Count
Range("G1", Range("G" & LastRow)).Copy ThisWorkbook.Sheets("Sheet1").Range(CurS.Cells(ThisRow, ThisCol + 1), CurS.Cells(ThisRow, ThisCol + CurS.Cells(ThisRow, InfCol).Value))
ActiveWorkbook.Save
ActiveWorkbook.Close
MyFile = Dir
Loop
End Sub
To properly copy in a new column each time, you need a variable that increments during each loop to offset by one each time. When you use ThisCol + 1 you're always getting the same value because ThisCol is not updated.
Something like this:
Sub Copy()
Dim MyFile As String
Dim Filepath As String
Dim q As Long
Dim ThisCol As Integer
Dim ThisRow As Long
Dim CurS As Worksheet
Dim CurRg As Range
Dim InfCol As Integer
Set CurS = ActiveSheet
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
InfCol = 1
Filepath = ReplacewithyouFilePath
MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
If MyFile = "Text to column.xlsm" Then
Exit Sub
End If
'Let's keep a reference to the workbook
Dim wb As Workbook
Set wb = Workbooks.Open(Filepath & MyFile)
'Let's keep a reference to the first sheet where the data is
Dim ws As Worksheet
Set ws = wb.Sheets(1)
Dim LastRow As Long
LastRow = ws.Range("G1").CurrentRegion.Rows.Count
'We create a variable to increment at each column
Dim Counter As Long
'Let's make the copy operation using the Counter
ws.Range("G1", ws.Range("G" & LastRow)).Copy CurS.Range(CurS.Cells(ThisRow, ThisCol + Counter), CurS.Cells(ThisRow + LastRow - 1, ThisCol + Counter))
'We increment the counter for the next file
Counter = Counter + 1
'We use wb to make sure we are referring to the right workbook
wb.Save
wb.Close
MyFile = Dir
'We free the variables for good measure
Set wb = Nothing
Set ws = Nothing
Loop
End Sub
Import Columns
Sub ImportColumns()
Const FOLDER_PATH As String = "C:\Test"
Const FILE_EXTENSION_PATTERN As String = "*.xls*"
Const SOURCE_WORKSHEET_ID As Variant = 1
Const SOURCE_COLUMN As String = "G"
Const SOURCE_FIRST_ROW As Long = 1
Const DESTINATION_WORKSHEET_NAME As String = "Sheet1"
Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
Const DESTINATION_COLUMN_OFFSET As Long = 1
Dim pSep As String: pSep = Application.PathSeparator
Dim FolderPath As String: FolderPath = FOLDER_PATH
If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
Dim DirPattern As String: DirPattern = FolderPath & FILE_EXTENSION_PATTERN
Dim SourceFileName As String: SourceFileName = Dir(DirPattern)
If Len(SourceFileName) = 0 Then
MsgBox "No files found.", vbExclamation
Exit Sub
End If
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.Worksheets(DESTINATION_WORKSHEET_NAME)
Dim dfCell As Range: Set dfCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
Application.ScreenUpdating = False
Dim swb As Workbook
Dim sws As Worksheet
Dim srg As Range
Dim sfCell As Range
Dim slCell As Range
Do While Len(SourceFileName) > 0
If StrComp(SourceFileName, "Text to column.xlsm", vbTextCompare) _
<> 0 Then ' Why 'Exit Sub'? Is this the destination file?
Set swb = Workbooks.Open(FolderPath & SourceFileName, True, True)
Set sws = swb.Worksheets(SOURCE_WORKSHEET_ID)
Set sfCell = sws.Cells(SOURCE_FIRST_ROW, SOURCE_COLUMN)
Set slCell = sws.Cells(sws.Rows.Count, SOURCE_COLUMN).End(xlUp)
Set srg = sws.Range(sfCell, slCell)
srg.Copy dfCell
' Or, if you only need values without formulas and formats,
' instead, use the more efficient:
'dfCell.Resize(srg.Rows.Count).Value = srg.Value
Set dfCell = dfCell.Offset(, DESTINATION_COLUMN_OFFSET) ' next col.
swb.Close SaveChanges:=False ' we are just reading, no need to save!
'Else ' it's "Text to column.xlsm"; do nothing
End If
SourceFileName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "Columns imported.", vbInformation
End Sub

Filename is empty when trying to open file

I try to merge workbooks from a folder in a new workbooks. The VBA code reads the excel file from folder, add every file name to a list box and then, after pressing the button "Start", add very file to the workbook. That is the idea.
The code is as folows:
When opening the file the userform is shown:
Private Sub Workbook_Open()
UserForm1.Show
End Sub
When activating userform, the list box is populated:
Private Sub UserForm_Activate()
Const strFolder As String = "C:\Users\user\Desktop\tmp\"
Const strPattern As String = "*.xls"
Dim strFile As String
Dim collection As New collection
Dim i As Integer
Dim isMerger As Integer
Dim lngth As Integer
strFile = Dir(strFolder & strPattern, vbNormal)
If (StrComp(strFile, "FileMerger.xls") <> 0) Then
If (Len(strFile) <> 0) Then
col.Add (strFolder & strFile)
Do While Len(strFile) > 0
strFile = Dir
If (StrComp(strFile, "FileMerger.xls") <> 0) Then
If (Len(strFile) <> 0) Then
col.Add (strFolder & strFile)
End If
End If
Loop
End If
End If
Vars.xlsFiles = ColToArray(collection)
For i = 1 To UBound(Vars.xlsFiles)
lstFiles.AddItem (Vars.xlsFiles(i))
Next i
End Sub
At this moment listbox and array Vars.xlsFiles are populated; they are OK.
Click on Start button in the userform:
Private Sub cmdStart_Click()
Dim fileName As String
Dim sheet As Worksheet
Dim i As Integer
Dim ub As Integer
ub = UBound(Vars.xlsFiles)
For i = 1 To ub
Workbooks.Open fileName:=Vars.xlsFiles(i), ReadOnly:=True
For Each sheet In ActiveWorkbook.Sheets
sheet.Copy After:=ThisWorkbook.Sheets(1)
Next sheet
Workbooks(fileName).Close
Next i
End Sub
In the folder are 3 files. Their name are in the listbox. But when the first is to be closed I received an error message and after debugging it says that fileName ="" (line Workbooks(fileName).Close).
whatever I try I got the same error, i.e. fileName = "".
What to do ?
Your never set the variable fileName, so it's still the default value "". Maybe you got confused by the fileName:=Vars.xlsFiles(i) of the Workbooks.Open method. That just sets the option FileName of that method. Use some unique name to avoid confusion and set it to Vars.xlsFiles(i) or use
Workbooks(Vars.xlsFiles(i)).close
FileName:= is a named parameter of the Workbooks.Open method. It does not set the value of the cmdStart_Click's fileName variable.
Private Sub cmdStart_Click()
Dim fileName As String
Dim sheet As Worksheet
Dim i As Integer
Dim ub As Integer
ub = UBound(Vars.xlsFiles)
For i = 1 To ub
fileName = Vars.xlsFiles(i)
Workbooks.Open FileName:=fileName, ReadOnly:=True
For Each sheet In ActiveWorkbook.Sheets
sheet.Copy After:=ThisWorkbook.Sheets(1)
Next sheet
Workbooks(fileName).Close
Next i
End Sub

Import text file to new sheet, do some operations, then close the sheet

I have a problem that I need help to solve. I want to import a text file to a new temporary sheet, find some data, put them in my current sheet and then close the new temporary sheet. Is this possible and how do I do this?
To create a new Worksheet, then remove it:
Option Explicit
Sub openWorkSheet()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets.Add(, ThisWorkbook.ActiveSheet)
End Sub
Sub closeWorkSheet(ByRef ws As Worksheet)
If Not ws Is Nothing Then
With Application
.DisplayAlerts = False
ws.Delete
.DisplayAlerts = True
End With
End If
End Sub
To open a text file, read its contents and find specific strings:
Public Sub searchFile(ByVal filePathAndName As String)
Const TYPICAL_START = "FIRST search string"
Const TYPICAL_END = "LAST search string"
Dim fso As Object
Dim searchedFile As Object
Dim fullFile As String
Dim foundStart As Long
Dim foundEnd As Long
Dim resultArr() As String
Dim i As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Set searchedFile = fso.OpenTextFile(filePathAndName)
fullFile = searchedFile.ReadAll 'read entire file
i = 1
foundStart = 1
foundStart = InStr(foundStart, fullFile, TYPICAL_START, vbTextCompare)
If foundStart > 0 Then
foundEnd = InStr(foundStart, fullFile, TYPICAL_END, vbTextCompare)
While foundStart > 0 And foundEnd > 0
ReDim Preserve resultArr(i)
resultArr(i) = Mid(fullFile, foundStart, foundEnd - foundStart + 1)
foundStart = InStr(foundStart + 1, fullFile, TYPICAL_START, vbTextCompare)
If foundStart > 0 Then foundEnd = InStr(foundStart, fullFile, TYPICAL_END)
i = i + 1
Wend
End If
End Sub
So now it shold work. This is the sub that does not want to work.
Sub Import()
Dim DestBook As Workbook, SourceBook As Workbook
Dim DestCell As Range
Dim RetVal As Boolean
' Set object variables for the active book and active cell.
Set DestBook = ActiveWorkbook
Set DestCell = ActiveCell
' Show the Open dialog box.
RetVal = Application.Dialogs(xlDialogOpen).Show("*.txt", , True)
' If Retval is false (Open dialog canceled), exit the procedure.
If RetVal = False Then Exit Sub
' Set an object variable for the workbook containing the text file.
Set SourceBook = ActiveWorkbook
' Copy the contents of the entire sheet containing the text file.
Range(Range("A1"), Range("A1").SpecialCells(xlLastCell)).Copy
' Activate the destination workbook and paste special the values
' from the text file.
DestBook.Activate
DestCell.PasteSpecial Paste:=xlValues
' Close the book containing the text file.
SourceBook.Close False
End Sub

Excel 2013: VBA create a range from X number of columns and save as a text file

So on my "sheet1" I have data in columns A, B, C, D, E, F
I would like VBA code to combine the 1st (A), 3rd(C) and 5th (E) column and save it to a comma separated text file.
I have:
Option Explicit
Public Sub ExcelRowsToCSV()
Dim iPtr As Integer
Dim sFileName As String
Dim intFH As Integer
Dim aRange As Range
Dim iLastColumn As Integer
Dim oCell As Range
Dim iRec As Long
Dim lenth As String
Set aRange = Range("A1:C11")
iLastColumn = aRange.Column + aRange.Columns.Count - 1
iPtr = InStrRev(ActiveWorkbook.FullName, ".")
sFileName = Left(ActiveWorkbook.FullName, iPtr - 1) & ".txt"
sFileName = Application.GetSaveAsFilename(InitialFileName:=sFileName, FileFilter:="TXT (Comma delimited) (*.txt), *.txt")
If sFileName = "False" Then Exit Sub
Close
intFH = FreeFile()
Open sFileName For Output As intFH
iRec = 0
For Each oCell In aRange
If oCell.Column = iLastColumn Then
Print #intFH, oCell.Value
iRec = iRec + 1
Else
Print #intFH, oCell.Value; ",";
iRec = iRec + 1
End If
Next oCell
Close intFH
MsgBox "Finished: " & CStr(iRec) & " records written to " _
& sFileName & Space(10), vbOKOnly + vbInformation
End Sub
This works but only if the range declared has columns that lay right next to each other.
The fastest way is to copy the worksheet as a new workbook and then delete unnecessary columns and then save the file as csv. This will not affect the original file as well.
For example (TRIED AND TESTED)
Option Explicit
Sub Sample()
Dim wb As Workbook
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
'~~> Copy the sheet as a new workbook
ws.Copy
ActiveSheet.Range("D:D,B:B,F:F").Delete Shift:=xlToLeft
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="C:\Sample.Csv", FileFormat:=xlCSV
ActiveWorkbook.Close (False)
Application.DisplayAlerts = True
End Sub
try changing your for each to this: (untested, but hope you get the idea)
dim str as string
For i= 1 to arange.rows
str=""
for j=1 to arange.columns
str=str & ","
next
Print #intFH, str
Next

Overlapping of images while pasting from one to another excel using VB

I am trying to paste few images from one excel to another, but facing an issue in it. the images are overlapping on each other., and even the size is very small.Below is the code of what i have tried.
If Source = ESNAME Then
Dim shp As Microsoft.Office.Interop.Excel.Shape
Dim lCol As Integer = 0
Dim I As Integer = 1
'~~> Loop through all shapes and find the last col of the shape
For Each shp In WS.Shapes
If shp.BottomRightCell.Column > lCol Then _
lCol = shp.BottomRightCell.Column
With WS
'~~> Find actual last Row
Dim LastRow As Integer = I
Dim LastColumn As Integer = I
Dim str As String = "B" & I & "#"
'~~> Check if we have the correct last columnm
If LastColumn < lCol Then LastColumn = lCol
.Range(str.Replace("#", ":") & Split(.Cells(, LastColumn).Address, "$")(1) & LastRow).Copy()
Dim sheet As Microsoft.Office.Interop.Excel.Worksheet
sheet = Nothing
sheet = DW.Worksheets(1)
sheet.Paste()
End With
I = I + 1
Next
End If
Thanks in advance.
Let's say your Workbook1 looks like this
Try this code (TRIED AND TESTED in VS 2010 + OFFICE 2010)
Code
Imports Excel = Microsoft.Office.Interop.Excel
Public Class Form1
Private Sub Button1_Click(sender As System.Object, e As System.EventArgs) Handles Button1.Click
'~~> Define your Excel Objects
Dim xlApp As New Excel.Application
Dim xlWorkBook1 As Excel.Workbook = Nothing
Dim xlWorkBook2 As Excel.Workbook = Nothing
Dim xlWorkSheet1 As Excel.Worksheet = Nothing
Dim xlWorkSheet2 As Excel.Worksheet = Nothing
'~~> Display Excel
xlApp.Visible = True
'~~> Open relevant excel files and set your objects
xlWorkBook1 = xlApp.Workbooks.Open("C:\book1.xlsx")
xlWorkSheet1 = xlWorkBook1.Sheets("Sheet1")
xlWorkBook2 = xlApp.Workbooks.Open("C:\book2.xlsx")
xlWorkSheet2 = xlWorkBook2.Sheets("Sheet2")
Dim xlShp As Excel.Shape = Nothing
Dim xlShape As Excel.Shape = Nothing
For Each xlShp In xlWorkSheet1.Shapes
xlShp.Copy()
xlWorkSheet2.Paste(Destination:=xlWorkSheet2.Range("A1"))
Next
Dim col1 As New Point(10, 10)
Dim col2 As New Point(col1.X * 2 + xlWorkSheet2.Shapes(0).Width, 10)
Dim stdHeight As Integer = CType(xlWorkSheet2.Shapes(0), Excel.Shape).Height + 5
For i As Integer = 0 To xlWorkSheet2.Shapes.Count - 1 Step 2
xlShape = xlWorkSheet2.Shapes(i)
xlShape.Left = col1.X
xlShape.Top = col1.Y + i * stdHeight
xlShape = xlWorkSheet2.Shapes(i + 1)
xlShape.Left = col2.X
xlShape.Top = col2.Y + i * stdHeight
Next
'~~> Save the file
xlWorkBook2.Save()
'~~> Close the File
xlWorkBook1.Close (False)
xlWorkBook2.Close (False)
'~~> Quit the Excel Application
xlApp.Quit()
'~~> Clean Up
releaseObject (xlShp)
releaseObject (xlShape)
releaseObject (xlWorkSheet1)
releaseObject (xlWorkSheet2)
releaseObject (xlWorkBook1)
releaseObject (xlWorkBook2)
releaseObject (xlApp)
End Sub
'~~> Release the objects
Private Sub releaseObject(ByVal obj As Object)
Try
System.Runtime.InteropServices.Marshal.ReleaseComObject (obj)
obj = Nothing
Catch ex As Exception
obj = Nothing
Finally
GC.Collect()
End Try
End Sub
End Class
Workbook 2 Output