Automate Text Import in Excel 2007 - vba
I'm trying to write an Excel macro using VBA to automate importing CSV text into a spreadsheet but I've never done it before. I need to make sure that the Text Import Wizard that comes up is run through the same way each time. The steps I need to take are:
Open a file, using an open file dialog
Set type to Delimited
Set Delimiter to comma
Set all columns to be imported as Text
Auto fit all columns
I can't seem to wade through the documentation that shows how to do these things like open files. Even being able to start there would be helpful.
The code below will allow a user to browse for a csv file.
It will then :
Open the selected file, treating the data as text
Resize the columns
Move the data into the workbook from which the code is run.
The .opentext code needs to be updated depending on the number of columns in the source data.
Sub ImportCSV()
Dim vPath As Variant
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Set wb = Excel.ActiveWorkbook
Set ws = Excel.ActiveSheet
vPath = Application.GetOpenFilename("CSV (Comma Delimited) (*.csv),*.csv" _
, 1, "Select a file", , False)
''//Show the file open dialog to allow user to select a CSV file
If vPath = False Then Exit Sub
''//Exit macro if no file selected
Workbooks.OpenText Filename:=vPath, Origin:=xlMSDOS, StartRow:=1 _
, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, Comma:=True _
, FieldInfo:=Array(Array(1, xlTextFormat), Array(2, xlTextFormat), _
Array(3, xlTextFormat))
''//The fieldinfo array needs to be extended to match your number of columns
Columns.EntireColumn.AutoFit
''//Resize the columns
Sheets(1).Move Before:=wb.Sheets(1)
''//Move the data into the Workbook
End Sub
Public Sub Example()
Const csPath As String = "C:\Test\Example.csv"
Dim ws As Excel.Worksheet
Set ws = Excel.ActiveSheet
With ws.QueryTables.Add("TEXT;" & csPath, ws.Cells(1, 1))
.FieldNames = True
.AdjustColumnWidth = True
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileCommaDelimiter = True
''// This array will need as many entries as there will be columns:
.TextFileColumnDataTypes = Array(xlTextFormat, xlTextFormat)
.Refresh
End With
End Sub
I ended up making some tweaks to the function before putting it into use.
Public Sub OpenCsv()
' I don't expect any more columns than 256 in my environment, so I can
' just fill this array and call it done.
Dim columnFormats(0 To 255) As Integer
For i = 0 To 255
columnFormats(i) = xlTextFormat
Next i
Dim filename As Variant
filename = Application.GetOpenFilename("All Files (*.*),*.*", 1, "Open", "", False)
' If user clicks Cancel, stop.
If (filename = False) Then
Exit Sub
End If
Dim ws As Excel.Worksheet
Application.Workbooks.Add
Set ws = Excel.ActiveSheet
Application.DisplayAlerts = False
Sheets("Sheet2").Delete
Sheets("Sheet3").Delete
Application.DisplayAlerts = True
With ws.QueryTables.Add("TEXT;" & filename, ws.Cells(1, 1))
.FieldNames = True
.AdjustColumnWidth = True
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileCommaDelimiter = True
''// This array will need as many entries as there will be columns:
.TextFileColumnDataTypes = columnFormats
.Refresh
End With
End Sub
Thanks to the above guys for getting me going.
Related
Excel VBA - Running a Macro against all files in a folder [duplicate]
I have a folder where I receive 1000+ excel files on daily bases they all are same format and structure. What I want to do is run a macro on all 100+ files on daily bases ? Is there way to automate this ? So I can keep running that same macro on 1000+ files daily.
Assuming that you put your files in "Files" directory relative to your master workbook your code might look like this: Sub ProcessFiles() Dim Filename, Pathname As String Dim wb As Workbook Pathname = ActiveWorkbook.Path & "\Files\" Filename = Dir(Pathname & "*.xls") Do While Filename <> "" Set wb = Workbooks.Open(Pathname & Filename) DoWork wb wb.Close SaveChanges:=True Filename = Dir() Loop End Sub Sub DoWork(wb As Workbook) With wb 'Do your work here .Worksheets(1).Range("A1").Value = "Hello World!" End With End Sub In this example DoWork() is your macro that you apply to all of your files. Make sure that you do all your processing in your macro is always in the context of the wb (currently opened workbook). Disclaimer: all possible error handling skipped for brevity.
A part of the question might be how do I run this on 1000 files?... Do I have to add this macro to all 1000 workbooks? One way to do this is to add your macro's centrally to the file PERSONAL.XLSB (sometimes the extension might be different). This file will be loaded in the background every time you start Excel and makes your macro's available at any time. Initially the PERSONAL.XLSB file will NOT be there. To automatically create this file, just start recording a "dummy" macro (with the record button on the left-bottom of a spreadsheet) and select "Personal Macro Workbook" to store it in. After recording your macro, you can open the VBA editor with Alt+F11 and you will see the PERSONAL.XLSB file with the "dummy" recorded macro. I use this file to store loads of general macro's which are always available, independent of which .xlsx file I have open. I have added these macro's to my own menu ribbon. One disadvantage of this common macro file is that if you launch more than one instance of Excel, you will get an error message that the PERSONAL.XLSB file is already in use by Excel instance Nr. 1. This is no problem as long as you do not add new macro's at this moment.
Thank you very much for this Sub ProcessFiles() Dim Filename, Pathname As String Dim wb As Workbook Pathname = ActiveWorkbook.Path & "C:\Users\jkatanan\Desktop\20170206Glidepath\V37\" Filename = Dir(Pathname & "*.xls") Do While Filename <> "" Set wb = Workbooks.Open(Pathname & Filename) BSAQmacro wb wb.Close SaveChanges:=True Filename = Dir() Loop End Sub Sub DoWork(wb As Workbook) With wb 'Do your work here .Worksheets(1).Range("A1").Value = "Hello World!" End With End Sub
Sub ProcessFiles() Dim Filename, Pathname As String Dim wb As Workbook Pathname = ActiveWorkbook.Path & "\C:\Users\20098323\Desktop\EXCL\" Filename = Dir(Pathname & "*.xlsx") Do While Filename <> "" Set wb = Workbooks.Open(Pathname & Filename) DoWork wb wb.Close SaveChanges:=True Filename = Dir() Loop End Sub Sub DoWork(wb As Workbook) With wb 'Do your work here .Worksheets(1).Range("A1").Value = "Hello World!" End With End Sub While running this code its showing bad file name or number. i have stored my all file in ("\C:\Users\20098323\Desktop\EXCL\") EXCL folder
Instead of passing the values to DoWork one can also run the jobs in Processfiles(). Sub ProcessFiles() Dim Filename, Pathname As String Dim wb1 As Workbook Dim wb2 As Workbook Dim Sheet As Worksheet Dim PasteStart As Range Dim Counter As Integer Set wb1 = ActiveWorkbook Set PasteStart = [RRimport!A1] Pathname = ActiveWorkbook.Path & "\For Macro to run\" Filename = Dir(Pathname & "*.xls") Do While Filename <> "" Set wb2 = Workbooks.Open(Pathname & Filename) For Each Sheet In wb2.Sheets With Sheet.UsedRange .Copy PasteStart Set PasteStart = PasteStart.Offset(.Rows.Count) End With Next Sheet wb2.Close Filename = Dir() Loop End Sub
This isn't an exact answer to the question, since I was just trying to run a single script on any file that I opened and couldn't get that to work, but I thought this might help others like me. It worked once I moved the code into a Module in the Visual Basic for Applications dialog box (go to "Insert" then "Module"). Once I added my VBA code to a module, I was able to open any other file in Excel (even a CSV file) and go to Macros, and run the Macro from the other file (that contains the Module with the code) on the file that I had open.
Thanks Peterm!! Actually, I did my macro using exactly the same code you posted (process_fiels and dowork). It worked brilliant!! (before my question) Each of my 1000 workbooks has 84 worksheets. My own macro (which finally works!) splits each workbook into 85 different files (the original + a short version of each worksheet saved as an individual file). That leaves me with 1000 files + 1000x85 in the same folder, and that would be really hard to sort out. What I really need is for Process_Files to take the first file, create a folder with the name of the first file, move the first file to the folder with ist name, then run my macro (in the folder named after the first file in the newly created folder...), go back and take the second file, create a folder with the name of the second file, move the second file to the folder with ist name, then run my macro (in the folder named after the second file in the newly created folder...), etc... At the end, I should have moved all files into folders with the same name as the files, and the contents of the original \Files\ folder would be 1000 folders with the name of the original files, containgin the original files + 84 files which my own macro already does. Maybe it is easier with the code: Sub ProcessFiles() Dim Filename, Pathname As String Dim wb As Workbook Pathname = ActiveWorkbook.Path & "\Files\" Filename = Dir(Pathname & "*.xls") Do While Filename <> "" (Here, it should read the file name, create a folder with the file name, move the file into this newly created folder) Set wb = Workbooks.Open(Pathname & Filename) <- open file, just as is. DoWork wb <- do my macro,just as is wb.Close SaveChanges:=False <- not save, to keep the original file (go back to the original \Files\ folder) Filename = Dir() <- Next file, just as is Loop End Sub Sub DoWork(wb As Workbook) With wb MyMacro End With End Sub Many thanks, this site is great! __________________edit, the macro now works _________________________ As you can see, I am no VBA expert, but the macro finally works. The code is not neat at all, I am no SW programmer. Here it is, it might help some one some day. Sub ProcessFiles_All() Dim Filename, Pathname, NewPath, FileSource, FileDestination As String Dim wb As Workbook Pathname = ActiveWorkbook.Path & "\Files\" Filename = Dir(Pathname & "*.csv") Do While Filename <> "" NewPath = Pathname & Left(Filename, 34) & "\" On Error Resume Next MkDir (NewPath) On Error GoTo 0 Set wb = Workbooks.Open(Pathname & Filename) DoWorkPlease wb ' <------------ It is important to say please!! On Error Resume Next wb.Close SaveChanges:=False if Err.Number <> 0 then ‘Error handler needed here End if Filename = Dir() Loop End Sub Sub DoWorkPlease(wb As Workbook) With wb ‘ Since my application has over 1800 cells for each column and it is time consuming ‘ I use a “testing mode” were I only play with 18 values. Dim TestingMode As Integer Dim ThisRange(1 To 4) As Variant TestingMode = 0 If TestingMode = 1 Then ThisRange(1) = "B2:CG18" ThisRange(2) = "CT2:CT18" ThisRange(3) = "CH2:CN18" ThisRange(4) = "CN2:CS18" Rows("19:18201").Select Selection.Delete Shift:=xlUp End If If TestingMode = 0 Then ThisRange(1) = "B2:CG18201" ThisRange(2) = "CT2:CT18201" ThisRange(3) = "CH2:CN18201" ThisRange(4) = "CN2:CS18201" End If ‘ speed up the macro, turn off updating and alerts Application.ScreenUpdating = False Application.DisplayAlerts = False ‘ Here is my code that manipulates the cell values from digits (values read by sensors need to be “translated” into real world values. Code not here actually. ‘Then I copy the whole thing into just numbers, there are no longer formulas, easier to work this way. '_____________________________________ 'Get just values - no more formulas Sheets.Add After:=Sheets(Sheets.Count) Sheets("Sheet1").Select Columns("A:CT").Select Selection.Copy Sheets("Sheet2").Select Columns("A:A").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False Selection.NumberFormat = "0" With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With ‘ Then I save this new workbook into a folder with its own name (and under the folder \FILES\ '_____________________________________ 'Save the work under its own folder Dim CleanName, CleanPath, CleanNewName As Variant CleanPath = ActiveWorkbook.Path CleanName = ActiveWorkbook.Name CleanName = Left(CleanName, 34) ‘I take out the extension CleanPath = CleanPath + "\" + CleanName CleanNewName = CleanPath + "\" + CleanName CleanNewName = CleanNewName + "_clean.csv" ‘ and I add “clean” to have a different name now. On Error Resume Next ActiveWorkbook.SaveAs Filename:=CleanNewName, FileFormat:=xlCSV, CreateBackup:=False ‘If there is an error I create an empty folder with the name of the file to know which file needs rework. If Err.Number <> 0 Then MkDir (CleanPath + "_error_" + CleanName) End If 'Resume Next ActiveSheet.Move _ After:=ActiveWorkbook.Sheets(1) ‘ Then I split the workbook into individual files with the data I need for individual sensors. ‘ Here are the individual ranges I need for each file. Since I have over 1000 files, it is worth the effort. '_______________ the Split!!______________________________ Dim Col(1 To 98) As Variant Col(1) = "A:A,B:B,CH:CH,CN:CN,CT:CT" Col(2) = "A:A,C:C,CH:CH,CN:CN,CT:CT" Col(3) = "A:A,D:D,CH:CH,CN:CN,CT:CT" Col(4) = "A:A,E:E,CH:CH,CN:CN,CT:CT" Col(5) = "A:A,F:F,CH:CH,CN:CN,CT:CT" Col(6) = "A:A,G:G,CH:CH,CN:CN,CT:CT" Col(7) = "A:A,H:H,CH:CH,CN:CN,CT:CT" Col(8) = "A:A,I:I,CH:CH,CN:CN,CT:CT" Col(9) = "A:A,J:J,CH:CH,CN:CN,CT:CT" Col(10) = "A:A,K:K,CH:CH,CN:CN,CT:CT" Col(11) = "A:A,L:L,CH:CH,CN:CN,CT:CT" Col(12) = "A:A,M:M,CH:CH,CN:CN,CT:CT" Col(13) = "A:A,N:N,CH:CH,CN:CN,CT:CT" Col(14) = "A:A,O:O,CH:CH,CN:CN,CT:CT" Col(15) = "A:A,P:P,CI:CI,CO:CO,CT:CT" Col(16) = "A:A,Q:Q,CI:CI,CO:CO,CT:CT" Col(17) = "A:A,R:R,CI:CI,CO:CO,CT:CT" Col(18) = "A:A,S:S,CI:CI,CO:CO,CT:CT" Col(19) = "A:A,T:T,CI:CI,CO:CO,CT:CT" Col(20) = "A:A,U:U,CI:CI,CO:CO,CT:CT" Col(21) = "A:A,V:V,CI:CI,CO:CO,CT:CT" Col(22) = "A:A,W:W,CI:CI,CO:CO,CT:CT" Col(23) = "A:A,X:X,CI:CI,CO:CO,CT:CT" Col(24) = "A:A,Y:Y,CI:CI,CO:CO,CT:CT" Col(25) = "A:A,Z:Z,CI:CI,CO:CO,CT:CT" Col(26) = "A:A,AA:AA,CI:CI,CO:CO,CT:CT" Col(27) = "A:A,AB:AB,CI:CI,CO:CO,CT:CT" Col(28) = "A:A,AC:AC,CI:CI,CO:CO,CT:CT" Col(29) = "A:A,AD:AD,CJ:CJ,CP:CP,CT:CT" Col(30) = "A:A,AE:AE,CJ:CJ,CP:CP,CT:CT" Col(31) = "A:A,AF:AF,CJ:CJ,CP:CP,CT:CT" Col(32) = "A:A,AG:AG,CJ:CJ,CP:CP,CT:CT" Col(33) = "A:A,AH:AH,CJ:CJ,CP:CP,CT:CT" Col(34) = "A:A,AI:AI,CJ:CJ,CP:CP,CT:CT" Col(35) = "A:A,AJ:AJ,CJ:CJ,CP:CP,CT:CT" Col(36) = "A:A,AK:AK,CJ:CJ,CP:CP,CT:CT" Col(37) = "A:A,AL:AL,CJ:CJ,CP:CP,CT:CT" Col(38) = "A:A,AM:AM,CJ:CJ,CP:CP,CT:CT" Col(39) = "A:A,AN:AN,CJ:CJ,CP:CP,CT:CT" Col(40) = "A:A,AO:AO,CJ:CJ,CP:CP,CT:CT" Col(41) = "A:A,AP:AP,CJ:CJ,CP:CP,CT:CT" Col(42) = "A:A,AQ:AQ,CJ:CJ,CP:CP,CT:CT" Col(43) = "A:A,AR:AR,CK:CK,CQ:CQ,CT:CT" Col(44) = "A:A,AS:AS,CK:CK,CQ:CQ,CT:CT" Col(45) = "A:A,AT:AT,CK:CK,CQ:CQ,CT:CT" Col(46) = "A:A,AU:AU,CK:CK,CQ:CQ,CT:CT" Col(47) = "A:A,AV:AV,CK:CK,CQ:CQ,CT:CT" Col(48) = "A:A,AW:AW,CK:CK,CQ:CQ,CT:CT" Col(49) = "A:A,AX:AX,CK:CK,CQ:CQ,CT:CT" Col(50) = "A:A,AY:AY,CK:CK,CQ:CQ,CT:CT" Col(51) = "A:A,AZ:AZ,CK:CK,CQ:CQ,CT:CT" Col(52) = "A:A,BA:BA,CK:CK,CQ:CQ,CT:CT" Col(53) = "A:A,BB:BB,CK:CK,CQ:CQ,CT:CT" Col(54) = "A:A,BC:BC,CK:CK,CQ:CQ,CT:CT" Col(55) = "A:A,BD:BD,CK:CK,CQ:CQ,CT:CT" Col(56) = "A:A,BE:BE,CK:CK,CQ:CQ,CT:CT" Col(57) = "A:A,BF:BF,CL:CL,CR:CR,CT:CT" Col(58) = "A:A,BG:BG,CL:CL,CR:CR,CT:CT" Col(59) = "A:A,BH:BH,CL:CL,CR:CR,CT:CT" Col(60) = "A:A,BI:BI,CL:CL,CR:CR,CT:CT" Col(61) = "A:A,BJ:BJ,CL:CL,CR:CR,CT:CT" Col(62) = "A:A,BK:BK,CL:CL,CR:CR,CT:CT" Col(63) = "A:A,BL:BL,CL:CL,CR:CR,CT:CT" Col(64) = "A:A,BM:BM,CL:CL,CR:CR,CT:CT" Col(65) = "A:A,BN:BN,CL:CL,CR:CR,CT:CT" Col(66) = "A:A,BO:BO,CL:CL,CR:CR,CT:CT" Col(67) = "A:A,BP:BP,CL:CL,CR:CR,CT:CT" Col(68) = "A:A,BQ:BQ,CL:CL,CR:CR,CT:CT" Col(69) = "A:A,BR:BR,CL:CL,CR:CR,CT:CT" Col(70) = "A:A,BS:BS,CL:CL,CR:CR,CT:CT" Col(71) = "A:A,BT:BT,CM:CM,CS:CS,CT:CT" Col(72) = "A:A,BU:BU,CM:CM,CS:CS,CT:CT" Col(73) = "A:A,BV:BV,CM:CM,CS:CS,CT:CT" Col(74) = "A:A,BW:BW,CM:CM,CS:CS,CT:CT" Col(75) = "A:A,BX:BX,CM:CM,CS:CS,CT:CT" Col(76) = "A:A,BY:BY,CM:CM,CS:CS,CT:CT" Col(77) = "A:A,BZ:BZ,CM:CM,CS:CS,CT:CT" Col(78) = "A:A,CA:CA,CM:CM,CS:CS,CT:CT" Col(79) = "A:A,CB:CB,CM:CM,CS:CS,CT:CT" Col(80) = "A:A,CC:CC,CM:CM,CS:CS,CT:CT" Col(81) = "A:A,CD:CD,CM:CM,CS:CS,CT:CT" Col(82) = "A:A,CE:CE,CM:CM,CS:CS,CT:CT" Col(83) = "A:A,CF:CF,CM:CM,CS:CS,CT:CT" Col(84) = "A:A,CG:CG,CM:CM,CS:CS,CT:CT" ‘ I want to split 84 new files, so for testing I use only 1, and for the real thing I go with 84 Dim CounterMode As Integer If TestingMode = 1 Then CounterMode = 1 Else CounterMode = 84 For i = 1 To CounterMode ‘ this code takes the columns need, and paste it into a new workbook. Sheets("Sheet1").Select Cells.Select Selection.ClearContents Range("A1").Activate Sheets(2).Select Range(Col(i)).Select Selection.Copy Sheets("Sheet1").Select ActiveSheet.Paste Application.CutCopyMode = False With Selection .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With Columns("A:E").EntireColumn.AutoFit ‘ Save the individual file '_____________save the work________________ Dim ThePath, TheName, TheSwitch As String ThePath = ActiveWorkbook.Path + “\” TheName = Left(ActiveWorkbook.Name, 34) ‘ take out the extension from the name ThePath = ThePath + TheName TheSwitch = Cells(3, 2) ‘ In Cell (3,2) I have the name of the individual name, so I added to the file name. TheName = ThePath + "_" + TheSwitch + ".xls" Range("A1").Select Sheets("Sheet1").Select Sheets("Sheet1").Copy Dim SheetName As Variant ‘ I name Sheets(1) as Sheet1, since the original sheet has the name and date of the test. ‘ I do this to have the same name on all file in order to do a plot, then I rename the sheet with the ‘ original name SheetName = ActiveSheet.Name ActiveWorkbook.Sheets(1).Name = "Sheet1" ‘ here is the plot Columns("A:E").EntireColumn.AutoFit Columns("B:E").Select ActiveSheet.Shapes.AddChart.Select ActiveChart.SetSourceData Source:=Range("'Sheet1'!$B:$E") ActiveChart.ChartType = xlXYScatterLinesNoMarkers ActiveWorkbook.Sheets(1).Name = SheetName ‘save On Error Resume Next ActiveWorkbook.SaveAs Filename:=TheName, FileFormat:=56, CreateBackup:=False If Err.Number <> 0 Then MkDir (ThePath + "_error_" + TheName) End If ActiveWorkbook.Close Next i '____________________That was the Split__________________________________ ' Turn on screenupdating: Application.ScreenUpdating = True Application.DisplayAlerts = True Range("A1").Select End With End Sub
Data validations lost when copying worksheet using VBA macro
Problem: I am having a problem with data validations not copying to the copied worksheet when a worksheet is copied using a macro. Is there any way to do this using my current code? Yes, I am also aware that there is a similar question (Here: Data validation lost when I copy a worksheet to another workbook) but it isn't quite the same issue and does not yet at this time have an answer. Any help to get these data validations to copy along with the data would be much appreciated and will save hours of needless repetitive work. Edit: This code is in the "ThisWorkbook" section of my workbook. My code is as follows: Dim wb As Workbook Dim wsTemp As Worksheet Dim sName As String Dim bValidName As Boolean Dim i As Long bValidName = False Do While bValidName = False sName = InputBox("Please name this new worksheet:", "New Sheet Name", Sh.Name) If Len(sName) > 0 Then For i = 1 To 7 sName = Replace(sName, Mid(":\/?*[]", i, 1), " ") Next i sName = Trim(Left(WorksheetFunction.Trim(sName), 31)) If Not Evaluate("ISREF('" & sName & "'!A1)") Then bValidName = True End If Loop With Application .ScreenUpdating = False .DisplayAlerts = False .EnableEvents = False End With Set wb = ThisWorkbook Set wsTemp = wb.Sheets("TEMPLATE") wsTemp.Visible = xlSheetVisible wsTemp.Copy After:=wb.Sheets(wb.Sheets.Count) ActiveSheet.Name = sName Sh.Delete wsTemp.Visible = xlSheetHidden 'Or xlSheetVeryHidden With Application .ScreenUpdating = True .DisplayAlerts = True .EnableEvents = True End With ' Call Sort_Active_book ' Call Rebuild_TOC
You should be able to copy a worksheet and retain DV. This example: Activates Sheet1 creates a simple DV on Sheeet1 copies Sheet1 to the end of the workbook Sub Macro2() Sheets("Sheet1").Select Range("D1").Select ActiveCell.FormulaR1C1 = "alpha" Range("D2").Select ActiveCell.FormulaR1C1 = "beta" Range("D3").Select ActiveCell.FormulaR1C1 = "gamma" Range("B1").Select With Selection.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="=$D$1:$D$3" .IgnoreBlank = True .InCellDropdown = True .InputTitle = "" .ErrorTitle = "" .InputMessage = "" .ErrorMessage = "" .ShowInput = True .ShowError = True End With Sheets("Sheet1").Select Sheets("Sheet1").Copy After:=Sheets(3) End Sub This is recorded code run on a new, empty workbook on a Win 7/Excel 2007 system. Can you replicate my result ?? If my code works on your system, begin by trying to mimic your VBA code manually with the recorder turned. Then take your recorded code and modify it to include non-recordable parts, (like the InputBox statements).
Debugging a QueryTables.Add script
Sub FindData() Dim accountNumber As Range Set accountNumber = Range(Range("A2"), Range("A2").End(xlDown)) Dim dataSet As QueryTable For Each Value In accountNumber Set dataSet = .QueryTables.Add( _ Connection:="URL;http://www.prad.org/CamaDisplay.aspx?OutputMode=Display&SearchType=RealEstate&ParcelID=" & Value, _ Destination:=ThisWorkbook.Worksheets(2).Range("A1")) Next Value With dataSet .RefreshOnFileOpen = False .WebFormatting = xlWebFormattingNone .BackgroundQuery = True .WebSelectionType = xlSpecifiedTables .WebTables = "3" End With With Application dataSet.Refresh BackgroundQuery:=False End With End Sub The ultimate goal here is to pull data from the URL and drop it into Worksheet(2). The values in accountNumber go at the end of the URL for each page to draw data from. This is my first VBA script, and right off the bat, it's giving me an error on Sub FindData() I have the table of accountNumbers. The URL for one account is the given URL with an accountNumber after the final =. I am trying to iterate through one webpage per accountNumber and extract from each.
Set dataSet = ActiveSheet.QueryTables.Add( _ Connection:="URL;http://www.prad.org/CamaDisplay.aspx?OutputMode=Display&SearchType=RealEstate&ParcelID=" & Value, _ Destination:=ThisWorkbook.Worksheets(2).Range("A1")) QueryTables needs to be properly referenced. You can use a sheet qualifier like : Sheets("yourname").QueryTables or something. You can remove the dot too...
Look into my code and see if this helps. I added a lot of comments to help you understand better the way the whole thing works. Option Explicit Sub FindData() Const strURL As String = "URL;http://www.prad.org/CamaDisplay.aspx?OutputMode=Display&SearchType=RealEstate&ParcelID=" Dim shActive As Worksheet Dim shDestination As Worksheet Dim oQuery As QueryTable Dim rAccounts As Range Dim rAccount As Range 'Initialize the variables Set shActive = ActiveSheet ' Note the "." in front of the ranges. That's how you use "With" With shActive Set rAccounts = .Range(.Range("A2"), .Range("A2").End(xlDown)) End With ' Remove any old query otherwise they will pile up and slow down ' your workbook Call RemoveSheetQueries(shActive) ' Loop through the accounts and add the queries For Each rAccount In rAccounts Set oQuery = Nothing Set oQuery = shActive.QueryTables.Add(Connection:=strURL & rAccount.Value, _ Destination:=shActive.Range("A1")) ' Set the properties of the new query and eventually run it. With oQuery .RefreshOnFileOpen = False .WebFormatting = xlWebFormattingNone .BackgroundQuery = True .WebSelectionType = xlSpecifiedTables .WebTables = "3" ' This last line will actually get the data .Refresh BackgroundQuery:=False End With Next rAccount End Sub ' Procedure to remove all old Queries Sub RemoveSheetQueries(ByRef shToProcess As Worksheet) Dim lTotal As Long Dim i As Long lTotal = shToProcess.QueryTables.Count For i = lTotal To 1 Step -1 shToProcess.QueryTables(i).Delete Next i End Sub I hope it helps :)
Mirror a single table to multiple sheets in excel using vba
I have one table in the database sheet in which i would want to paste link to another sheet. However i realised that it is not possible using excel and vba. Is there any ways to reference these tables automatically? Equating the cell ranges is one way that i know of but it is extremely tedious because i have over 50 tables of such. Hard coding these equations are a trouble.This is a basic code I have done to copy paste a table . Sub table() ActiveSheet.ListObjects("Table1").Range.Copy 'This code will run only when the cursor is at activesheet Sheets("Sheeet2").Range("A2").PasteSpecial xlPasteValues End Sub
Here is an example of how to add Table Connections to a new Workbook and a way to Refresh the tables. The code steps through each ListObject in ListObjects (Tables), .Add's the connection to the new Workbook and places the Table into the Worksheet. It then creates a new Worksheet and process the next ListObject. You can change the Workbook and Worksheet names + path to your needs. *Do note that for unknown reasons to me the Table mixes the rownumbers up when placing them into the new Worksheet, it however doesn't mix the Columns. AddTableConnectionsToNewWB code: Sub AddTableConnectionsToNewWB() Dim tbl As ListObject Dim tblConn As ListObjects Dim wb As Workbook Application.ScreenUpdating = False Set wb = Workbooks("TableConnections.xlsm") Set tblConn = Workbooks("TestBook3.xlsm").Worksheets("Sheet2").ListObjects For Each tbl In tblConn wb.Connections.Add2 "WorksheetConnection_TestBook3.xlsm!" & tbl, _ "", "WORKSHEET;H:\Projects\TestBook3.xlsm", "TestBook3.xlsm!" & tbl, 7, True, _ False If wb.Worksheets.Count = 1 Then With ActiveSheet.ListObjects.Add(SourceType:=4, Source:=ActiveWorkbook. _ Connections("WorksheetConnection_TestBook3.xlsm!" & tbl), Destination:=Range( _ "$A$1")).TableObject .RowNumbers = False .PreserveFormatting = True .RefreshStyle = 1 .AdjustColumnWidth = True .ListObject.DisplayName = tbl.Name .Refresh End With wb.Worksheets.Add after:=wb.Worksheets(Worksheets.Count) Else With ActiveSheet.ListObjects.Add(SourceType:=4, Source:=ActiveWorkbook. _ Connections("WorksheetConnection_TestBook3.xlsm!" & tbl), Destination:=Range( _ "$A$1")).TableObject .RowNumbers = False .PreserveFormatting = True .RefreshStyle = 1 .AdjustColumnWidth = True .ListObject.DisplayName = tbl.Name .Refresh End With If tblConn.Item(tblConn.Count).Name <> tbl.Name Then wb.Worksheets.Add after:=wb.Worksheets(Worksheets.Count) End If End If Next Application.ScreenUpdating = False End Sub Refresh code (this can also be done by simply clicking the refresh all button in Table Tools): Sub RefreshTableConnections() Dim wb As Workbook Application.ScreenUpdating = False Set wb = Workbooks("TableConnections.xlsm") wb.RefreshAll Application.ScreenUpdating = True End Sub
Import 150 text files to Access as Tables using SQL
I have 150 text files in csv format using pipe | as a seperator. the files are in different folders on a network. The filenames are date specific and have a suffix which holds the date. I have created a table which has 3 fields: File Location; File Name excluding suffix; suffix (in format yymmdd). I want to create an SQL script which will import each of the 150 files named in the table that I have created into 150 seperate Access 2007 tables named as the File Name excluding Suffix. I tried to do this using VBA but the filenames contain full stops and VBA didn't like this. Each of the files has a different column structure but the first row is always headers. I can only use Features native to Access 2007 as the organisation I work for does not allow third party addons or applications. I don't have SQL server available to me. I am a complete novice when it comes to Access and am struggling to achieve anything approaching this. Can you help?
I struggled to achieve what I wanted in Access and so went over to Excel instead. The code below creates each of the text files as a sheet within a single Excel workbook with the Master table holding the filename / path etc as a "Master" Sheet within the workbook. It deletes all of the sheets other than "Master" before recreating them and if a file is not found it will leave a blank sheet. Sub ImportFiles() 'This script looks at a Master list of files for import and imports each to their own tab 'The files are pipe (|) delimited and can be in any addressable location 'If any files are not found, the import of that file is skipped, leaving a blank worksheet 'Close the Report File before starting the import Application.DisplayAlerts = False On Error Resume Next Windows("Report.xlsx").Activate Windows("Report.xlsx").Close SaveChanges:=True On Error GoTo 0 Application.DisplayAlerts = True 'Start by looking at the sheet which contains the Master list of files Sheets("Master").Activate 'declare three arrays of unknown length Dim FileName() As String Dim FilePath() As String Dim FullName() As String 'initially there are no files Dim NumberFiles As Integer NumberFiles = 0 'loop over all of the file cells 'The master file needs to be structured FileName, FilePath and FullName in that order 'Change C2 to the cell containing the first FileName in the Master List Dim FileCell As Range Dim TopCell As Range Dim FileRange As Range Set TopCell = Range("C2") Set FileRange = Range(TopCell, TopCell.End(xlDown)) For Each FileCell In FileRange 'we've found another file! NumberFiles = NumberFiles + 1 'for each file found, extend all arrays ReDim Preserve FileName(NumberFiles - 1) ReDim Preserve FilePath(NumberFiles - 1) ReDim Preserve FullName(NumberFiles - 1) 'now store the filename, path and fullname of the new file FileName(NumberFiles - 1) = FileCell.Value FilePath(NumberFiles - 1) = FileCell.Offset(0, 1).Value FullName(NumberFiles - 1) = FileCell.Offset(0, 2).Value Next FileCell 'delete any existing sheets except Master and create new blank sheets For Each Sheet In Application.Worksheets Application.DisplayAlerts = False If Sheet.Name <> "Master" Then Sheet.Delete End If Next Sheet Sheets("Master").Activate For i = 1 To (NumberFiles) Worksheets.Add(After:=Sheets(Sheets.Count)).Name = "Sheet" & i Next i ThisWorkbook.Sheets("Sheet1").Select 'Start the process of import 'create a workbook object for the workbook where the current macro is running Dim ws As Worksheet 'import each file into its own sheet For i = 0 To (NumberFiles - 1) Set ws = ThisWorkbook.Sheets("Sheet" & i + 1) 'the current sheet 'Ignore any missing files and carry on processing Application.DisplayAlerts = False On Error Resume Next 'This imports the delimited files With ws.QueryTables.Add(Connection:="TEXT;" & FullName(i), Destination:=ws.Range("$A$1")) .Name = "a" & i .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .TextFilePromptOnRefresh = False .TextFilePlatform = 850 .TextFileStartRow = 1 .TextFileParseType = xlDelimited .TextFileTextQualifier = xlTextQualifierDoubleQuote .TextFileConsecutiveDelimiter = False .TextFileTabDelimiter = True .TextFileSemicolonDelimiter = False .TextFileCommaDelimiter = False .TextFileSpaceDelimiter = False .TextFileOtherDelimiter = "|" .TextFileColumnDataTypes = Array(1, 1, 1) .TextFileTrailingMinusNumbers = True .Refresh BackgroundQuery:=False End With 'Rename tabs to name on master list ws.Name = "" & FileName(i) Next i 'Reopen the Report File Workbooks.Open FileName:=ThisWorkbook.Path & "\Report.xlsx" End Sub