1, Create excel sheet
Dim WS as Worksheet
Set WS = Sheets.Add
You don't have to know where is it located, what's it's name, you just refer to it as WS.
If you still want to do this the "old fashioned" way, try this:
Sheets.Add.Name = "Test"
2, Create content
Option Explicit
Sub CreateTOC()
'Declare all variables
Dim ws As Worksheet, curws As Worksheet, shtName As String
Dim nRow As Long, i As Long, N As Long, x As Long, tmpCount As Long
Dim cLeft, cTop, cHeight, cWidth, cb As Shape, strMsg As String
Dim cCnt As Long, cAddy As String, cShade As Long
'Check if a workbook is open or not. If no workbook is open, quit.
If ActiveWorkbook Is Nothing Then
MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
Exit Sub
End If
'-------------------------------------------------------------------------------
cShade = 37 '<<== SET BACKGROUND COLOR DESIRED HERE
'-------------------------------------------------------------------------------
'Turn off events and screen flickering.
Application.ScreenUpdating = False
Application.DisplayAlerts = False
nRow = 4: x = 0
'Check if sheet exists already; direct where to go if not.
On Error Goto hasSheet
Sheets("TOC").Activate
'Confirm the desire to overwrite sheet if it exists already.
If MsgBox("You already have a Table of Contents page. Would you like to overwrite it?", _
vbYesNo + vbQuestion, "Replace TOC page?") = vbYes Then Goto createNew
Exit Sub
hasSheet:
x=1
'Add sheet as the first sheet in the workbook.
Sheets.Add before:=Sheets(1)
Goto hasNew
createNew:
Sheets("TOC").Delete
Goto hasSheet
hasNew:
'Reset error statment/redirects
On Error Goto 0
'Set chart sheet varible counter
tmpCount = ActiveWorkbook.Charts.Count
If tmpCount > 0 Then tmpCount = 1
'Set a little formatting for the TOC sheet.
ActiveSheet.Name = "TOC"
With Sheets("TOC")
.Cells.Interior.ColorIndex = cShade
.Rows("4:65536").RowHeight = 16
.Range("A1").Value = "Designed by VBAX"
.Range("A1").Font.Bold = False
.Range("A1").Font.Italic = True
.Range("A1").Font.Name = "Arial"
.Range("A1").Font.Size = "8"
.Range("A2").Value = "Table of Contents"
.Range("A2").Font.Bold = True
.Range("A2").Font.Name = "Arial"
.Range("A2").Font.Size = "24"
.Range("A4").Select
End With
'Set variables for loop/iterations
N = ActiveWorkbook.Sheets.Count + tmpCount
If x = 1 Then N = N - 1
For i = 2 To N
With Sheets("TOC")
'Check if sheet is a chart sheet.
If IsChart(Sheets(i).Name) Then
'** Sheet IS a Chart Sheet
cCnt = cCnt + 1
shtName = Charts(cCnt).Name
.Range("C" & nRow).Value = shtName
.Range("C" & nRow).Font.ColorIndex = cShade
'Set variables for button dimensions.
cLeft = .Range("C" & nRow).Left
cTop = .Range("C" & nRow).Top
cWidth = .Range("C" & nRow).Width
cHeight = .Range("C" & nRow).RowHeight
cAddy = "R" & nRow & "C3"
'Add button to cell dimensions.
Set cb = .Shapes.AddShape(msoShapeRoundedRectangle, _
cLeft, cTop, cWidth, cHeight)
cb.Select
'Use older technique to add Chart sheet name to button text.
ExecuteExcel4Macro "FORMULA(""=" & cAddy & """)"
'Format shape to look like hyperlink and match background color (transparent).
With Selection
.ShapeRange.Fill.ForeColor.SchemeColor = 0
With .Font
.Underline = xlUnderlineStyleSingle
.ColorIndex = 5
End With
.ShapeRange.Fill.Visible = msoFalse
.ShapeRange.Line.Visible = msoFalse
.OnAction = "Mod_Main.GotoChart"
End With
Else
'** Sheet is NOT a Chart sheet.
shtName = Sheets(i).Name
'Add a hyperlink to A1 of each sheet.
.Range("C" & nRow).Hyperlinks.Add _
Anchor:=.Range("C" & nRow), Address:="#'" & _
shtName & "'!A1", TextToDisplay:=shtName
.Range("C" & nRow).HorizontalAlignment = xlLeft
End If
.Range("B" & nRow).Value = nRow - 2
nRow = nRow + 1
End With
continueLoop:
Next i
'Perform some last minute formatting.
With Sheets("TOC")
.Range("C:C").EntireColumn.AutoFit
.Range("A4").Activate
End With
'Turn events back on.
Application.DisplayAlerts = True
Application.ScreenUpdating = True
strMsg = vbNewLine & vbNewLine & "Please note: " & _
"Charts will have hyperlinks associated with an object."
'Toggle message box for chart existence or not, information only.
If cCnt = 0 Then strMsg = ""
MsgBox "Complete!" & strMsg, vbInformation, "Complete!"
End Sub
Public Function IsChart(cName As String) As Boolean
'Will return True or False if sheet is a Chart sheet object or not.
'Can be used as a worksheet function.
Dim tmpChart As Chart
On Error Resume Next
'If not a chart, this line will error out.
Set tmpChart = Charts(cName)
'Function will be determined if the variable is now an Object or not.
IsChart = IIf(tmpChart Is Nothing, False, True)
End Function
Private Sub GotoChart()
'This routine written to be assigned to button Object for Chart sheets only
'as Chart sheets don't have cell references to hyperlink to.
Dim obj As Object, objName As String
'With the button text as the Chart name, we use the Caller method to obtain it.
Set obj = ActiveSheet.Shapes(Application.Caller)
'The latter portion of the AlternativeText will give us the exact Chart name.
objName = Trim(Right(obj.AlternativeText, Len(obj.AlternativeText) - _
InStr(1, obj.AlternativeText, ": ")))
'Then we can perform a standard Chart sheet Activate method using the variable.
Charts(objName).Activate
'Optional: zoom Chart sheet to fit screen.
'Depending on screen resolution, this may need adjustment(s).
ActiveWindow.Zoom = 80
End Sub
3, Open file
ctlComDlg.InitDir = MasterDBPath
ctlComDlg.FileName = ""
ctlComDlg.Filter = "excell(*.xls)|*.xls"
' Specify default filter
ctlComDlg.FilterIndex = 1
' Display the Open dialog box
ctlComDlg.ShowOpen
' Display name of selected file
Me.txtSelectDB = ctlComDlg.FileName
Exit Sub
Sub OpenSingleFile()
Dim Filter As String, Title As String
Dim FilterIndex As Integer
Dim Filename As Variant
' File filters
Filter = "Excel Files (*.xls),*.xls," & _
"Text Files (*.txt),*.txt," & _
"All Files (*.*),*.*"
' Default Filter to *.*
FilterIndex = 3
' Set Dialog Caption
Title = "Select a File to Open"
' Select Start Drive & Path
ChDrive ("E")
ChDir ("E:\Chapters\chap14")
With Application
' Set File Name to selected File
Filename = .GetOpenFilename(Filter, FilterIndex, Title)
' Reset Start Drive/Path
ChDrive (Left(.DefaultFilePath, 1))
ChDir (.DefaultFilePath)
End With
' Exit on Cancel
If Filename = False Then
MsgBox "No file was selected."
Exit Sub
End If
' Open File
Workbooks.Open Filename
MsgBox Filename, vbInformation, "File Opened" ' This can be removed
End Sub
To open multiple files (or a single file)
CODE
Sub OpenMultipleFiles()
Dim Filter As String, Title As String, msg As String
Dim i As Integer, FilterIndex As Integer
Dim Filename As Variant
' File filters
Filter = "Excel Files (*.xls),*.xls," & _
"Text Files (*.txt),*.txt," & _
"All Files (*.*),*.*"
' Default filter to *.*
FilterIndex = 3
' Set Dialog Caption
Title = "Select File(s) to Open"
' Select Start Drive & Path
ChDrive ("E")
ChDir ("E:\Chapters\chap14")
With Application
' Set File Name Array to selected Files (allow multiple)
Filename = .GetOpenFilename(Filter, FilterIndex, Title, , True)
' Reset Start Drive/Path
ChDrive (Left(.DefaultFilePath, 1))
ChDir (.DefaultFilePath)
End With
' Exit on Cancel
If Not IsArray(Filename) Then
MsgBox "No file was selected."
Exit Sub
End If
' Open Files
For i = LBound(Filename) To UBound(Filename)
msg = msg & Filename(i) & vbCrLf ' This can be removed
Workbooks.Open Filename(i)
Next i
MsgBox msg, vbInformation, "Files Opened"' This can be removed
End Sub
Import CSV file into excel using VBA
Asked by PKS6A in Microsoft Excel Spreadsheet Software, VB Database Programming, VB Script
Tags: Microsoft VBA, Excel, Macro, VBA
Hi I presently have a difficulty with importing csv files into excel using VBA. I have created a macro
'Imports text file into Excel workbook using ADO.
'If the number of records exceeds 65536 then it splits it over more than one sheet.
Dim strFilePath As String, strFilename As String, strFullPath As String
Dim lngCounter As Long
Dim oConn As Object, oRS As Object, oFSObj As Object
'Get a text file name
strFullPath = Application.GetOpenFilename("Text Files (*.csv),*.csv", , "Please selec text file...")
If strFullPath = "False" Then Exit Sub 'User pressed Cancel on the open file dialog
'This gives us a full path name e.g. C:tempfolderfile.txt
'We need to split this into path and file name
Set oFSObj = CreateObject("SCRIPTING.FILESYSTEMOBJECT")
strFilePath = oFSObj.GetFile(strFullPath).ParentFolder.Path
strFilename = oFSObj.GetFile(strFullPath).Name
'Open an ADO connection to the folder specified
Set oConn = CreateObject("ADODB.CONNECTION")
oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strFilePath & ";" & _
"Extended Properties=""text;HDR=Yes;FMT=Delimited"""
Set oRS = CreateObject("ADODB.RECORDSET")
'Now actually open the text file and import into Excel
oRS.Open "SELECT * FROM " & strFilename, oConn, 3, 1, 1
While Not oRS.EOF
Sheets.Add
ActiveSheet.Range("A1").CopyFromRecordset oRS, 65536
Wend
oRS.Close
DNA, how good are your programming skills?
As you can see, I've written a script that reads the contents of a CSV file into a 2D array, connects
Its cheap, its nasty (and yes all you code Nazi's, I know there are better ways to code some of this s
Dim objConn
Dim Cells(30,1000)
ReadCsv("c:\file.csv")
Set objConn = CreateObject("ADODB.Connection")
objConn.Open "Driver={Microsoft Access Driver (*.mdb)};DBQ=C:\MyAccessDatabase.mdb;"
For i = 1 to UBound(Cells)
If Cells(1, i) <> "" Then
'The cell isnt emtpy so lets do some work on this row...
objConn.Execute("INSERT INTO table (column_1, column_2, column_n) VALUES ('" & cells(1,i) & "'
End IF
Next
objConn.Close
Set objConn = Nothing
Sub ReadCSV(sFilename)
Dim fso, f, line, Column, CellStart, CellEnd, Row
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile(sFilename, 1)
Row = 0
While Not f.AtEndOfStream
line = """" & Replace(f.ReadLine, ",", """,""") & """"
Row = Row + 1
Column = 0
While line <> ""
Column = Column + 1
CellStart = 2
CellEnd = InStr(2, line, """", vbTextCompare)
Cells(Row, Column) = Mid(line, CellStart, CellEnd - CellStart)
line = Mid(line, CellEnd + 2)
Wend
RowCount = Row
Wend
f.Close
Set f = Nothing
Set fso = Nothing
End Sub
Sheet
Get, Set Value for Cell on sheets
Get sheets name
Sub ShowWorkSheets()
Dim mySheet As Worksheet
For Each mySheet In Worksheets
MsgBox mySheet.Name
Next mySheet
End Sub
'Set value for cell
Sub CellsExample()
For i = 1 To 5
For J = 1 To 5
Cells(i, J) = "Row " & i & " Col " & J
Next J
Next i
End Sub
'Place a "1" one row under E5 (on E6)
Sub CellsPlaceUnder()
ActiveCell.Offset(1, 0) = 1
End Sub
'Place a "1" one column to the right of E5 (on F5)
Sub CellsPlaceRight()
ActiveCell.Offset(0, 1) = 1
End Sub
'Place a "1" three columns to the left of E5 (on B5)
Sub CellsPlaceLeft()
ActiveCell.Offset(0, -3) = 1
End Sub
'Range Object and Cells Property
Sub RangeObjectCellsProperty()
'Set value for cells A1,A5,A5
'Worksheets("Ex2").Range("A1, A3, A5") = "AAA"
'Set value for cells from A1,B5
'Worksheets("Ex2").Range("A1:B5") = "AB"
'Set value for 20th cell(from letf to right)
'Cells(20) = "XYZ"
'Set value for A1 cell
'Range("A1") = 123
'Set value for A1 cell on current sheet equal A10 cell on sheet2
Range("D16:D20") = Worksheets("Ex2").Range("C9")
'Display Message
MsgBox ("Get Value Succesful!")
End Sub
OPEN File - Set Active on Cell in other Sheet
Dim Filename As String
Dim Filter As String, Title As String
Dim FilterIndex As Integer
Filter = "Excel Files (*.xls),*.xls," & _
"Text Files (*.txt),*.txt," & _
"All Files (*.*),*.*"
' Default Filter to *.*
FilterIndex = 3
Title = "Select a File to Open"
' Select Start Drive & Path
ChDrive ("E")
ChDir ("E:\")
With Application
' Set File Name to selected File
Filename = .GetOpenFilename(Filter, FilterIndex, Title)
' Reset Start Drive/Path
ChDrive (Left(.DefaultFilePath, 1))
ChDir (.DefaultFilePath)
End With
' Active sheet on current workbook
ActiveWorkbook.Sheets("Information").Activate
' Focus on cell of current worksheet
Worksheets("Information").Range("A1").Select
Import CSV file
Private pfile As String
Private dfile As String
Private fileToOpne As Variant
Private i, j, k, l As Integer
Private a As Variant
Dim order_estimate(1 To 12) As Double
Dim sell_estimate(1 To 12) As Double
Dim revenue_firm_estimate(1 To 12) As Double
Dim revenue_estimate(1 To 12) As Double
' Write Data from csv File
'row1,row2,row3,row4: Position (Area with Category)
Sub WriteData(row1, row2, row3, row4)
m=2
For i = 1 To 12
m=m+1
Worksheets("Template").Cells(row1, m) = order_estimate(i)
Worksheets("Template").Cells(row2, m) = sell_estimate(i)
Worksheets("Template").Cells(row3, m) = revenue_firm_estimate(i)
Worksheets("Template").Cells(row4, m) = revenue_estimate(i)
Next
End Sub
Sub GetData()
'Get file name of xls file
pfile = ActiveWorkbook.Name
'Import csv file
fileToOpen = Application.GetOpenFilename( _
filefilter:="CSV (*.csv), *.csv", _
Title:="Hello!", MultiSelect:=False)
If fileToOpen <> False Then
Workbooks.Open fileName:=fileToOpen
Else
End
End If
'Get file name of csv file
dfile = ActiveWorkbook.Name
'Get Category of csv file
Category = Workbooks(dfile).Worksheets(1).Cells(4, 4)
'Get Data of items in csv file set to array
h=0
For i = 6 To 28
Workbooks(pfile).Activate
If i Mod 2 = 0 Then
h=h+1
order_estimate(h) = Workbooks(dfile).Worksheets(1).Cells(i, 2)
sell_estimate(h) = Workbooks(dfile).Worksheets(1).Cells(i, 3)
revenue_firm_estimate(h) = Workbooks(dfile).Worksheets(1).Cells(i, 5)
revenue_estimate(h) = Workbooks(dfile).Worksheets(1).Cells(i, 6)
End If
Next
st refer to it as WS.
Count As Long
mation, "No Open Book"
uld you like to overwrite it?", _
n Goto createNew
round color (transparent).
t sheets only
thod to obtain it.
ct Chart name.
iveText) - _
d using the variable.
using VBA
tabase Programming, VB Script
ng VBA. I have created a macro which is meant to read each record from a csv file and put it into excel. The code also needs to handle
than one sheet.
csv", , "Please selec text file...")
the open file dialog
SV file into a 2D array, connects to an access database and inserts the values into the table.
better ways to code some of this stuff but in my defense its a copy/paste from a couple of different projects of mine that were'nt made to
AccessDatabase.mdb;"
mn_n) VALUES ('" & cells(1,i) & "', '" & Cells(2,i) & "', '" & Cells(3,i)"');")
l. The code also needs to handle the splitting into different sheets when the csv file has more than the allowed 65536 rows. Can you ple
ects of mine that were'nt made to work together) but with some minor modifications it could work for you.
allowed 65536 rows. Can you please help. My code is ignoring the first record, thus not bringing back all records. code below.
all records. code below.
