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

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

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

VBA - Rename worksheet after source file

I have a question as to how to rename a sheet after the source file name, but only a portion of it. So if the file name is "010117Siemens Hot - Cold Report .xls", I want just the first numbers. So in short, I would like "Sheet2" for example to be called "010117".
Sub ImportData()
Application.ScreenUpdating = False
Dim wkbCrntWorkBook As Workbook
Dim wkbSourceBook As Workbook
Dim fNameAndPath As Variant
Set wkbCrntWorkBook = ActiveWorkbook
fNameAndPath = Application.GetOpenFilename(FileFilter:="Excel 2007, *.xls; *.xlsx; *.xlsm; *.xlsa", Title:="Select File To Import")
If fNameAndPath = False Then Exit Sub
Call ReadDataFromSourceFile(fNameAndPath)
Set wkbCrntWorkBook = Nothing
Set wkbSourceBook = Nothing
ActiveWorkbook.Worksheets("Set Up").Select
End Sub
Sub ReadDataFromSourceFile(filePath As Variant)
Application.ScreenUpdating = False
Dim n As Double
Dim wksNew As Excel.Worksheet
Dim src As Workbook
Set src = Workbooks.Open(filePath, False, False)
Dim srcRng As Range
With src.Worksheets("Sheet1")
Set srcRng = .Range(.Range("A1"), .Range("A1").End(xlDown).End(xlToRight))
End With
With ThisWorkbook
Set wksNew = .Worksheets.Add(After:=.Worksheets(.Sheets.Count))
n = .Sheets.Count
.Worksheets(n).Range("A1").Resize(srcRng.Rows.Count, srcRng.Columns.Count).Value = srcRng.Value
End With
' CLOSE THE SOURCE FILE.
src.Close False ' FALSE - DON'T SAVE THE SOURCE FILE.
Set src = Nothing
End Sub
Thanks in advance!
Use the RegEx object to extract the numeric part (from 1 to 9 consecutive numeric) from the file name (src.Name).
Code
Sub ReadDataFromSourceFile(filePath As Variant)
Application.ScreenUpdating = False
Dim n As Double
Dim wksNew As Excel.Worksheet
Dim src As Workbook
Set src = Workbooks.Open(filePath, False, False)
Dim srcRng As Range
With src.Worksheets("Sheet1")
Set srcRng = .Range(.Range("A1"), .Range("A1").End(xlDown).End(xlToRight))
End With
With ThisWorkbook
Set wksNew = .Worksheets.Add(After:=.Worksheets(.Sheets.Count))
n = .Sheets.Count
.Worksheets(n).Range("A1").Resize(srcRng.Rows.Count, srcRng.Columns.Count).Value = srcRng.Value
End With
' ======= get the digits part from src.Name using a RegEx object =====
' RegEx variables
Dim Reg As Object
Dim RegMatches As Variant
Set Reg = CreateObject("VBScript.RegExp")
With Reg
.Global = True
.IgnoreCase = True
.Pattern = "\d{0,9}" ' Match any set of 0 to 9 digits
End With
Set RegMatches = Reg.Execute(src.Name)
If RegMatches.Count >= 1 Then ' make sure there is at least 1 match
ThisWorkbook.Worksheets(n).Name = RegMatches(0) ' rename new sheets to the numeric part of the filename
End If
' CLOSE THE SOURCE FILE.
src.Close False ' FALSE - DON'T SAVE THE SOURCE FILE.
Set src = Nothing
End Sub

Copy Worksheets break links

I have the below 2 subs in VBA which perform 2 different but similar tasks. One allows you to selects sheets from a Workbook using a checkbox popup and then copies these sheets into a new blank Workbook. The other allows you to manually populate a list of names of the sheets you want to copy (i.e. setup a "batch" of sorts) on a sheet and then copy all the sheets across into a new blank Workbook in a similar fashion to the first.
The problem I am having is - with the first sub I am able to break links after copying into the new Workbook, but with the second sub I am not able to break links. I think it has to do with a number of defined names within the original Workbook, as if you "Move or Copy/Create a Copy" manually, you are able to break the links.
Is there any code I can add to the below (onto both subs if possible) which will automatically break all links in the new Workbook to the old one? Or at least, is it possible to amend the second sub so that it copies across in a similar fashion to the first one which will then allow me to break links manually?
Sub CopySelectedSheets()
'1. Declare variables
Dim I As Integer
Dim SheetCount As Integer
Dim TopPos As Integer
Dim lngCheckBoxes As Long, y As Long
Dim intTopPos As Integer, intSheetCount As Integer
Dim intHor As Integer
Dim intWidth As Integer
Dim intLBLeft As Integer, intLBTop As Integer, intLBHeight As Integer
Dim Printdlg As DialogSheet
Dim CurrentSheet As Worksheet, wsStartSheet As Worksheet
Dim CB As CheckBox
Dim firstSelected As Boolean
' Dim wb As Workbook
' Dim wbNew As Workbook
' Set wb = ThisWorkbook
' Workbooks.Add ' Open a new workbook
' Set wbNew = ActiveWorkbook
On Error Resume Next
Application.ScreenUpdating = False
'2. Check for protected workbook
If ActiveWorkbook.ProtectStructure Then
MsgBox "Workbook is protected.", vbCritical
Exit Sub
End If
'3. Add a temporary dialog sheet
Set CurrentSheet = ActiveSheet
Set wsStartSheet = ActiveSheet
Set Printdlg = ActiveWorkbook.DialogSheets.Add
SheetCount = 0
'4. Add the checkboxes
TopPos = 40
For I = 1 To ActiveWorkbook.Worksheets.Count
Set CurrentSheet = ActiveWorkbook.Worksheets(I)
'Skip empty sheets and hidden sheets
If Application.CountA(CurrentSheet.Cells) <> 0 And _
CurrentSheet.Visible Then
SheetCount = SheetCount + 1
Printdlg.CheckBoxes.Add 78, TopPos, 150, 16.5
Printdlg.CheckBoxes(SheetCount).Text = _
CurrentSheet.Name
TopPos = TopPos + 13
End If
Next I
'6. Move the OK and Cancel buttons
Printdlg.Buttons.Left = 240
'7. Set dialog height, width, and caption
With Printdlg.DialogFrame
.Height = Application.Max _
(68, Printdlg.DialogFrame.Top + TopPos - 34)
.Width = 230
.Caption = "Select sheets to generate"
End With
'Change tab order of OK and Cancel buttons
'so the 1st option button will have the focus
Printdlg.Buttons("Button 2").BringToFront
Printdlg.Buttons("Button 3").BringToFront
'9. Display the dialog box
CurrentSheet.Activate
wsStartSheet.Activate
Application.ScreenUpdating = True
If SheetCount <> 0 Then
If Printdlg.Show Then
For Each CB In Printdlg.CheckBoxes
If CB.Value = xlOn Then
If firstSelected Then
Worksheets(CB.Caption).Select Replace:=False
Else
Worksheets(CB.Caption).Select
firstSelected = True
End If
'For y = 1 To ActiveWorkbook.Worksheets.Count
'If WorksheetFunction.IsNumber _
'(InStr(1, "ActiveWorkbook.Sheets(y)", "Contents")) = True Then
'CB.y = xlOn
'End If
End If
Next
ActiveWindow.SelectedSheets.Copy
Else
MsgBox "No worksheets selected"
End If
End If
' Delete temporary dialog sheet (without a warning)
'' Application.DisplayAlerts = False
'' Printdlg.Delete
' Reactivate original sheet
'' CurrentSheet.Activate
'' wsStartSheet.Activate
'10.Delete temporary dialog sheet (without a warning)
Application.DisplayAlerts = False
Printdlg.Delete
'11.Reactivate original sheet
CurrentSheet.Activate
wsStartSheet.Activate
Application.DisplayAlerts = True
End Sub
Sub CopySpecificSheets()
'1. Declare Variables
Dim myArray() As String
Dim myRange As Range
Dim Cell As Range
Dim OldBook As String
Dim newBook As String
Dim a As Long
'2. Set Range of Lookup
Set myRange = Sheets("Report Batch").Range("A2:A40")
OldBook = ActiveWorkbook.Name
'3. Generate Array of Sheet Names removing Blanks
For Each Cell In myRange
If Not Cell = "" Then
a = a + 1
ReDim Preserve myArray(1 To a)
myArray(a) = Cell
End If
Next
'4. Copy Array of Sheets to new Workbook
For a = 1 To UBound(myArray)
If a = 1 Then
Sheets(myArray(a)).Copy
newBook = ActiveWorkbook.Name
Workbooks(OldBook).Activate
Else
Sheets(myArray(a)).Copy After:=Workbooks(newBook).Sheets(a - 1)
Workbooks(OldBook).Activate
End If
Next
End Sub
Try something like this:
Sub CopySpecificSheets()
'1. Declare Variables
Dim rngData As Range
Dim arrData As Variant
Dim arrSheets() As String
Dim lSheetCount As Long
Dim i As Long
Dim j As Long
'2. Initialize variables
Set rngData = Sheets("Report Batch").Range("A2:A40")
arrData = rngData.Value
lSheetCount = WorksheetFunction.CountA(rngData)
ReDim arrSheets(lSheetCount - 1)
'3. Fill the array with non blank sheet names
For i = LBound(arrData) To UBound(arrData)
If arrData(i, 1) <> vbNullString Then
arrSheets(j) = arrData(i, 1)
j = j + 1
End If
' early break if we have all the sheets
If j = lSheetCount Then
Exit For
End If
Next i
'4. Copy the sheets in one step
Sheets(arrSheets).Copy
End Sub
Thanks
This isn't tested, but I think if you add in a subroutine to your source workbook VBA code like this:
Sub BreakLinks(ByRef wb As Workbook)
Dim Links As Variant
Dim i As Long
On Error Resume Next
Links = wb.LinkSources(Type:=xlLinkTypeExcelLinks)
On Error GoTo 0
If Not IsEmpty(Links) Then
For i = 1 To UBound(Links)
wb.BreakLink Name:=Links(i), _
Type:=xlLinkTypeExcelLinks
Next i
End If
End Sub
And then call it after you copy the sheets to the new workbook
Call BreakLinks(newBook)
That should achieve the desired effect of severing those links. Just be sure the links are broken to any sort of Save or SaveAs operation so that the broken links are maintained.

Import/export named ranges and their values to and from workbook to .csv

I have a .csv with two columns: colA has named ranges and colB has the values.
Now I need to import the values from the .csv and assign them to the named ranges in the workbook present in multiple sheets. Also I need to export the same in the same manner. i.e. A workbook has named ranges and obviously some associated values.
Is there a way to export in the same format so that I can use it to import them later?
For import I modified the code provided as an answer below but still unsuccessful:
Option Explicit
Sub impdata()
'This is to import data from csv to xlsm
Dim MyCSV As Workbook
Dim filename As String
Dim curfilename As String
Dim MyRange As Range
Dim MyCell As Range
Dim x As Long
Dim y As Workbook
curfilename = ThisWorkbook.Name
filename = Application.GetOpenFilename
Set y = Workbooks(curfilename)
Application.ScreenUpdating = False
Set MyCSV = Workbooks.Open(filename)
Set MyRange = MyCSV.Worksheets("Import").Range("B2:B7")
x = 1
For Each MyCell In MyRange.Cells
Range(ThisWorkbook.Names(MyCell.Offset(, -1).Value)).Cells(x) = MyCell.Value 'Method "Range_of_object" Global failed
x = x + 1
Next MyCell
MyCSV.Close SaveChanges:=False
Application.DisplayAlerts = False
End Sub
This will read the values in from the CSV - providing the Named Range and values in the CSV are the same size and a single column.
In my example code the CSV has two different named ranges - A1:A3 hold 'NamedRangeA' and B1:B3 hold the values, A4:A6 hold 'NamedRangeB' and B4:B6 hold the values. There are two named ranges in the Excel workbook, both 3 rows by 1 column.
Sub ReadIn()
Dim MyCSV As Workbook
Dim MyRange As Range
Dim MyCell As Range
Dim x As Long
Set MyCSV = Workbooks.Open("C:\Documents and Settings\crladmin.ADMINNOT\Desktop\New Folder\NamesToRanges.CSV")
Set MyRange = MyCSV.Worksheets("NamesToRanges").Range("A1:B6")
x = 1
For Each MyCell In MyRange.Columns(2).Cells
Range(ThisWorkbook.Names(MyCell.Offset(, -1).Value)).Cells(x) = MyCell.Value
x = x + 1
Next MyCell
End Sub
Will hopefully point you in the right direction - just have to figure out the reading out to a CSV now.
Edit:
Have rewritten the code:
It will now ask you for the location of your CSV, it will use the first (and only) sheet in the CSV.
Have also got rid of the X variable as realised it wouldn't work if your named ranges weren't. Will now put the next value in the next empty cell in your named range.
Sub impdata()
Dim MyCSV As Workbook
Dim MyCSVPath As String
Dim MyRange As Range
Dim MyCell As Range
Dim MyNextCell As Range
Dim MyNamedRange As Range
MyCSVPath = GetFile
If MyCSVPath <> "" Then
Set MyCSV = Workbooks.Open(MyCSVPath)
Set MyRange = MyCSV.Worksheets(1).Range("B2:B7") 'Ensure B2:B7 is where your values are.
ThisWorkbook.Activate
For Each MyCell In MyRange.Cells
'Get a reference to the named range.
Set MyNamedRange = Range(ThisWorkbook.Names(MyCell.Offset(, -1).Value))
'Find the next empty cell in the named range.
Set MyNextCell = MyNamedRange.Cells(MyNamedRange.Cells.Count).End(xlUp).Offset(1)
'If the next empty cell is above the named range, then set
'it to the first cell in the range.
If MyNextCell.Row < MyNamedRange.Cells(1).Row Then
Set MyNextCell = MyNamedRange.Cells(1)
End If
'Place the value in the range.
MyNextCell = MyCell.Value
Next MyCell
End If
MyCSV.Close False
End Sub
'---------------------------------------------------------------------------------------
' Procedure : GetFile
' Date : 13/11/2013
' Purpose : Returns the full file path of the selected file
' To Use : vFile = GetFile()
' : vFile = GetFile("S:\Bartrup-CookD\Customer Services Phone Reports")
'---------------------------------------------------------------------------------------
Function GetFile(Optional startFolder As Variant = -1) As Variant
Dim fle As FileDialog
Dim vItem As Variant
Set fle = Application.FileDialog(msoFileDialogFilePicker)
With fle
.Title = "Select a File"
.AllowMultiSelect = False
.Filters.Add "Comma Separate Values", "*.CSV", 1
If startFolder = -1 Then
.InitialFileName = Application.DefaultFilePath
Else
If Right(startFolder, 1) <> "\" Then
.InitialFileName = startFolder & "\"
Else
.InitialFileName = startFolder
End If
End If
If .Show <> -1 Then GoTo NextCode
vItem = .SelectedItems(1)
End With
NextCode:
GetFile = vItem
Set fle = Nothing
End Function

Visual Studio 2015 - Manipulating Excel?

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