I have a list of text values each of which is the name of a Named Table on a different Worksheet of my Workbook.
Colum1 Value
Table1 True
Table2 False
Table3 False
Table4 True
Table5 True
My VBA code is going through the list like so:
For Each cell In MyRange
If cell.Offset(0, 1).Value = "True" Then
Call WriteTXTFile(cell.Value)
End If
Next cell
The WriteTXTFile subroutine needs to take the Table name and use it as a range to get all the data from the table and export it as a pipe-delimited TXT file like so:
Private Sub WriteTXTFile(TableName As String)
Dim TableRange As Range
Set TableRange = Range(TableName & "[#All]")
Const ForReading = 1, ForWriting = 2, ForAppending = 3
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Dim filesys, filenm, txtstrm
Dim CurrentCell As String
Set filesys = CreateObject("Scripting.FileSystemObject")
filesys.CreateTextFile ThisWorkbook.Path & "\" & TableName & ".txt"
Set filenm = filesys.GetFile(ThisWorkbook.Path & "\" & TableName & ".txt")
Set txtstrm = filenm.OpenAsTextStream(ForWriting, TristateFalse)
For Each cell In TableRange
CurrentCell = cell.Value
txtstrm.Write (Chr(124) & CurrentCell)
Next cell
txtstrm.Close
However, I keep getting an error:
"Method Range of object _Global failed."
I'm sure there's something wrong with the way the subroutine sets the TableRange, but I can't find any information on how to pass a Named Table name as a string to a subroutine and use it in a range.
Related
I've managed to piece together this VBA which takes data from excel and turns it into .txt flat file. It works exactly as I need, but I would like to alter it so that the end result is saved as Unicode as opposed to ANSI.
I've done some reading and the answer I keep coming back to is to use FileSystemObject. I found a VBA on here that does the job perfectly, but I can't for the life of me work out how to incorporate it into my existing code. Any chance someone could throw me some pointers?
This is my current code:
' Defines everything first. So, from B2, across and down.
LastRow = Sheets("Pricing").Range("B" & Rows.Count).End(xlUp).Row
LastColumn = Sheets("Pricing").Cells(2, Columns.Count).End(xlToLeft).Column
' File name, path to save to and delimiter.
file = Sheets("Pricing").TextBox1 & ".txt"
If TextBox1.Value = "" Then MsgBox "What we calling it genius?", vbQuestion
If TextBox1.Value = "" Then Exit Sub
Path = "C:\Users\me.me\Desktop\Files\"
Delimeter = "|"
' The magic bit.
myFileName = Path & file
FN = FreeFile
Open myFileName For Output As #FN
For Row = 2 To LastRow
For Column = 2 To LastColumn
If Column = 2 Then Record = Trim(Cells(Row, Column)) Else Record = Record & Delimeter & Trim(Cells(Row, Column))
Next Column
Print #FN, Record
Next Row
Close #FN
MsgBox "BOOM! LOOKIT ---> " & myFileName
' Opens the finished file.
Dim fso As Object
Dim sfile As String
Set fso = CreateObject("shell.application")
sfile = "C:\Users\me.me\Desktop\Files\" & Sheets("Pricing").TextBox1 & ".txt"
fso.Open (sfile)
And this is what I've been trying to incorporate (HUGE thanks to MarkJ for posting this on another question):
Dim fso As Object, MyFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set MyFile = fso.CreateTextFile("c:\testfile.txt", False,True) 'Unicode=True'
MyFile.WriteLine("This is a test.")
MyFile.Close
I just can't get it to work.
Please, test the next code. You did not answer my clarification question, but it works using the above comment assumptions. It take the file name, from an activeX text box situated on the sheet to be processed. The code should be faster than yours for big ranges, avoiding to iterate between all cells:
Sub SaveAsUnicode()
Dim shP As Worksheet, iRow As Long, Record As String, Delimeter As String
Dim file As String, myFileName As String, path As String, txtB As MSForms.TextBox
Dim rng As Range, lastCell As Range, arr, arrRow
Dim fso As Object, MyFile As Object, shApp As Object
Set shP = Worksheets("Pricinig")
Set txtB = shP.OLEObjects("TextBox1").Object 'it sets an activeX sheet text box
file = txtB.Text & ".txt"
If txtB.value = "" Then MsgBox "What we calling it genius?", vbQuestion: Exit Sub
Set lastCell = shP.cells.SpecialCells(xlCellTypeLastCell) 'last cell of the sheet
Set rng = shP.Range("A2", lastCell) 'create the range to be processed
arr = rng.value 'put the range in an array
path = "C:\Users\me.me\Desktop\Files\" 'take care to adjust the path!
myFileName = path & file
Delimeter = "|"
Set fso = CreateObject("Scripting.FileSystemObject")
Set MyFile = fso.CreateTextFile(myFileName, False, True) 'open the file to write Unicode:
For iRow = 1 To UBound(arr) 'itereate between the array rows
arrRow = Application.Index(arr, iRow, 0) 'make a slice of the currrent arrray row
Record = Join(arrRow, Delimeter) 'join the iD obtained array, using the set Delimiter
MyFile.WriteLine (Record) 'write the row in the Unicode file
Next iRow
MyFile.Close 'close the file
'open the obtained Unicode file:
Set shApp = CreateObject("shell.application")
shApp.Open (myFileName)
End Sub
I tested the above code on a sheet using characters not supported in ANSI and it works as expected.
Please, send some feedback after testing it, or if my assumptions after reading your question are not correct...
#FaneDuru, this is what I ended up putting together, it's working great for me. Thanks again for all of your help.
Private Sub FlatButton_Click()
'Does all the setup stuff.
Dim fso As Object, MyFile As Object
Dim MyFileName As String
Dim txtB As MSForms.TextBox
Set shP = Worksheets("Pricing")
Set txtB = shP.OLEObjects("TextBox1").Object
file = txtB.Text & ".txt"
If txtB.Value = "" Then MsgBox "What we calling it?", vbQuestion: Exit Sub
' Defines the range. So, from B2, across and down.
LastRow = Sheets("Pricing").Range("B" & Rows.Count).End(xlUp).Row
LastColumn = Sheets("Pricing").Cells(2, Columns.Count).End(xlToLeft).Column
'File details.
path = "C:\Users\me.me\Blah\Blah\"
MyFileName = path & file
Delimeter = "|"
' The magic bit.
Set fso = CreateObject("Scripting.FileSystemObject")
Set MyFile = fso.CreateTextFile(MyFileName, False, True) '<==== This defines the Unicode bit.
For Row = 2 To LastRow
For Column = 2 To LastColumn
If Column = 2 Then Record = Trim(Cells(Row, Column)) Else Record = Record & Delimeter & Trim(Cells(Row, Column))
Next Column
MyFile.WriteLine (Record)
Next Row
MyFile.Close
MsgBox "BOOM! ---> " & MyFileName
'Option to open the finished product.
If ActiveSheet.CheckBox2.Value = True Then
Set shApp = CreateObject("shell.application")
shApp.Open (MyFileName)
End If
End Sub
I wrote a macro that works out quite well. I'm able to copy and paste given range (to be precise a pivot table) as bitmap but the problem is that not the whole are is copied, only a part of a table.
Here is the code, what's wrong with pasting? Why can't I copy the whole table?
Public Sub Lotus_Mail()
Dim NSession As Object
Dim NUIWorkSpace As Object
Dim NDatabase As Object
Dim NDoc As Object
Dim NUIdoc As Object
Dim Subject As String
Dim SendTo As String, CopyTo As String
Dim pivots As Range
Dim Month As String
Dim text1 As Range
Dim text2 As Range
Dim i As Integer
Dim arrHUBs(1 To 8) As String
arrHUBs(1) = "a"
arrHUBs(2) = "b"
arrHUBs(3) = "c"
arrHUBs(4) = "d"
arrHUBs(5) = "e"
arrHUBs(6) = "f"
arrHUBs(7) = "g"
arrHUBs(8) = "h"
Week = DatePart("ww", Date, vbMonday, vbFirstFourDays)
Month = MonthName(DatePart("m", Date), False)
On Error Resume Next
For x = 1 To 8
SendTo = Application.WorksheetFunction.VLookup(arrHUBs(x), Sheets("Mail").Range("A2:C9"), 2, 0)
CopyTo = Application.WorksheetFunction.VLookup(arrHUBs(x), Sheets("Mail").Range("A2:C9"), 3, 0)
Subject = "Summary " & arrHUBs(x) & " - " & Month & ": week " & Week
'area to select (pivot table)
rows = Sheets("sheet").Cells(Rows.Count, 21).End(xlUp).Row
columns = Sheets("sheet").Cells(6, Columns.Count).End(xlToLeft).Column
Set pivots = Sheets("sheet").Range(Cells(4, 19), Cells(wiersz, kolumna))
'Set pivots = Sheets("sheet").PivotTables("Pivot1") ???this line doesn't work, any other way to select pivot and paste to Lotus?
Set text1 = Sheets("Mail").Range("A12")
Set text2 = Sheets("Mail").Range("A13")
'Lotus step by step
Set NSession = CreateObject("Notes.NotesSession")
Set NUIWorkSpace = CreateObject("Notes.NotesUIWorkspace")
Set NDatabase = NSession.GetDatabase("", "")
If Not NDatabase.IsOpen Then NDatabase.OPENMAIL
'creating mail
Set NDoc = NDatabase.CreateDocument
With NDoc
.SendTo = SendTo
.CopyTo = CopyTo
.Subject = Subject
'Email body text, including a placeholder which will be replaced by Excel table
.body = text1 & vbLf & vbLf & _
"{IMAGE_PLACEHOLDER}" & vbLf
.Save True, False
End With
'Edit the new document using Notes UI to copy and paste pivot table into it
Set NUIdoc = NUIWorkSpace.EDITDocument(True, NDoc)
With NUIdoc
Sheets("sheet").Select
'Find the placeholder in the Body item
.GotoField ("Body")
.FINDSTRING "{IMAGE_PLACEHOLDER}"
'.DESELECTALL 'Uncomment to leave the placeholder in place (cells are inserted immediately before it)
'Copy pivot table (being a range) as a bitmap to the clipboard and paste into the email
pivots.CopyPicture xlBitmap
.Paste 'maybe any paste special option exists?
Application.CutCopyMode = False
'.Send
'.Close
End With
Set NSession = Nothing
Next x
End Sub
Thank you for your answers
Looking to loop the following code through (about) 125 worksheets in an Excel workbook and pull the listed cell values into one database entry log on the 'Database' worksheet'. Right now it is only pulling from one of the tabs . (PO VT-0189). Wondering how to correct.
Private Sub PopulateOrderInfo()
Dim OrderDate As String, PONumber As String, Vendor As String, ShipTo As String, SKU As String
Dim R As Long, LastSKURow As Long, NextDBRow As Long, OFrm As Worksheet, DB As Worksheet
For Each OFrm In ActiveWorkbook.Worksheets
Set OFrm = Worksheets("PO VT-0189")
Set DB = Worksheets("Database")
OrderDate = OFrm.Range("N4")
PONumber = OFrm.Range("N3")
Vendor = OFrm.Range("A13")
ShipTo = OFrm.Range("I13")
POTotal = OFrm.Range("P43")
LastSKURow = OFrm.Range("A38").End(xlUp).Row
For R = 21 To LastSKURow
SKU = OFrm.Range("A" & R).Value
SKUDesc = OFrm.Range("D" & R).Value
SKUQty = OFrm.Range("K" & R).Value
Lntotal = OFrm.Range("M" & R).Value
NextDBRow = DB.Cells(DB.Rows.Count, "A").End(xlUp).Row + 1
DB.Range("A" & NextDBRow).Value = OrderDate
DB.Range("B" & NextDBRow).Value = PONumber
DB.Range("C" & NextDBRow).Value = Vendor
DB.Range("D" & NextDBRow).Value = ShipTo
DB.Range("E" & NextDBRow).Value = SKU
DB.Range("F" & NextDBRow).Value = SKUDesc
DB.Range("G" & NextDBRow).Value = SKUQty
DB.Range("H" & NextDBRow).Value = Lntotal
DB.Range("I" & NextDBRow).Value = POTotal
Next R
Next OFrm
End Sub
I think you can also shorten your code by avoiding the loop and most of the variables seem unnecessary to me.
Private Sub PopulateOrderInfo()
Dim R As Long, LastSKURow As Long, NextDBRow As Long, OFrm As Worksheet, DB As Worksheet
Set DB = Worksheets("Database")
For Each OFrm In ActiveWorkbook.Worksheets
If OFrm.Name <> DB.Name Then
LastSKURow = OFrm.Range("A38").End(xlUp).Row
R = LastSKURow - 21 + 1
NextDBRow = DB.Cells(DB.Rows.Count, "A").End(xlUp).Row + 1
DB.Range("A" & NextDBRow).Resize(R).Value = OFrm.Range("N4")
DB.Range("B" & NextDBRow).Resize(R).Value = OFrm.Range("N3")
DB.Range("C" & NextDBRow).Resize(R).Value = OFrm.Range("A13")
DB.Range("D" & NextDBRow).Resize(R).Value = OFrm.Range("I13")
DB.Range("E" & NextDBRow).Resize(R).Value = OFrm.Range("A21").Resize(R).Value
DB.Range("F" & NextDBRow).Resize(R).Value = OFrm.Range("D21").Resize(R).Value
DB.Range("G" & NextDBRow).Resize(R).Value = OFrm.Range("K21").Resize(R).Value
DB.Range("H" & NextDBRow).Resize(R).Value = OFrm.Range("M21").Resize(R).Value
DB.Range("I" & NextDBRow).Resize(R).Value = OFrm.Range("P43")
End If
Next OFrm
End Sub
Use a for loop and WorkSheets collection like:
For I = 1 to worksheets.count
if worksheets(i).name <> "Database" then
Add your code here
end if
Next i
This loops through every worksheet in your workbook and does what ever you need to all worksheets except the Database.
Using a for each... loop
For Each ws In wb.Worksheets
If ws.name = "Database" Then
'Leave blank to just skip database. Code here if you want something special on database. OR statements can be used to exclude additional sheets
Else
'Code here
End If
Next
I think you described the issue fairly well. Just to confirm, you want to loop through all worksheets in one single workbook, right. Try the script below. Feedback if you have additional questions, concerns, etc. Thanks.
Sub ImportAll()
Dim blnHasFieldNames As Boolean, blnEXCEL As Boolean, blnReadOnly As Boolean
Dim lngCount As Long
Dim objExcel As Object, objWorkbook As Object
Dim colWorksheets As Collection
Dim strPathFile as String, strTable as String
Dim strPassword As String
' Establish an EXCEL application object
On Error Resume Next
Set objExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set objExcel = CreateObject("Excel.Application")
blnEXCEL = True
End If
Err.Clear
On Error GoTo 0
' Change this next line to True if the first row in EXCEL worksheet
' has field names
blnHasFieldNames = False
' Replace C:\Filename.xls with the actual path and filename
strPathFile = "C:\Filename.xls"
' Replace tablename with the real name of the table into which
' the data are to be imported
strTable = "tablename"
' Replace passwordtext with the real password;
' if there is no password, replace it with vbNullString constant
' (e.g., strPassword = vbNullString)
strPassword = "passwordtext"
blnReadOnly = True ' open EXCEL file in read-only mode
' Open the EXCEL file and read the worksheet names into a collection
Set colWorksheets = New Collection
Set objWorkbook = objExcel.Workbooks.Open(strPathFile, , blnReadOnly, , _
strPassword)
For lngCount = 1 To objWorkbook.Worksheets.Count
colWorksheets.Add objWorkbook.Worksheets(lngCount).Name
Next lngCount
' Close the EXCEL file without saving the file, and clean up the EXCEL objects
objWorkbook.Close False
Set objWorkbook = Nothing
If blnEXCEL = True Then objExcel.Quit
Set objExcel = Nothing
' Import the data from each worksheet into the table
For lngCount = colWorksheets.Count To 1 Step -1
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
strTable, strPathFile, blnHasFieldNames, colWorksheets(lngCount) & "$"
Next lngCount
' Delete the collection
Set colWorksheets = Nothing
' Uncomment out the next code step if you want to delete the
' EXCEL file after it's been imported
' Kill strPathFile
End Sub
At this moment for the sake of simplicity I created just 3 excel files : Book1, Book2, Book3, each one with 2 columns. I looped through all excel files and populate all variables in my array, but I'm not able to display the values that I need in my Search excel file. One column is MyValue and the other column is a Value that i need to be shown in my Search excel file (the one with my macro).
MyValue can have multiple rows with the same value and I should take all the Values(which are not the same) and display them.
Sub MyFunction()
Dim MyValue As String
Dim MyFolder As String 'Path containing the files for looping
Dim MyFile As String 'Filename obtained by Dir function
Dim Matrice() As Variant
Dim Dim1, Dim2 As Long
MyFolder = "E:\Excel Files\" 'Assign directory to MyFolder variable
MyFile = Dir(MyFolder) 'Dir gets the first file of the folder
Application.ScreenUpdating = False
MyValue = InputBox("Type the Value")
'Loop through all files until Dir cannot find anymore
Do While MyFile <> ""
Set wbk = Workbooks.Open(Filename:=MyFolder & MyFile)
'Sheets1.Activate
Dim1 = Range("A2", Range("A1").End(xlDown)).Cells.Count - 1
Dim2 = Range("A1", Range("A1").End(xlToRight)).Cells.Count - 1
ReDim Matrice(0 To Dim1, 0 To Dim2)
'The statements you want to run on each file
For Dim1 = LBound(Matrice, 1) To UBound(Matrice, 1)
For Dim2 = LBound(Matrice, 2) To UBound(Matrice, 2)
Matrice(Dim1, Dim2) = Range("A2").Offset(Dim1, Dim2).Value
If Matrice(Dim1, Dim2) = MyValue Then
ThisWorkbook.Activate
Range("A1", Range("A2").End(xlDown)) = Matrice(Dim1, Dim2 + 1)
' Values that i want to be displayed on column A in my Search.xlsm file
' is not displayed any value
End If
Next Dim2
Next Dim1
wbk.Close savechanges:=True
MyFile = Dir 'Dir gets the next file in the folder
Loop
End Sub
Hope I understood your post, the code below copies only Value data where Cells value (in Column B) = MyValue into the Matrice() array.
Edit 1: Removes the section taht removes all Value duplicates.
Copies all Values to ThisWorkbook ("Sheet1").
Option Explicit
Sub MyFunction()
Dim MyValue As String
Dim MyFolder As String 'Path containing the files for looping
Dim MyFile As Variant 'Filename obtained by Dir function
Dim wbk As Workbook
Dim wSht As Worksheet
Dim Matrice() As Variant
Dim Dim1, Dim2 As Long
Dim i, j As Long
Dim Matrice_size As Long
MyFolder = "\\EMEA.corning.com\ACGB-UD$\UD2\radoshits\My Documents\_Advanced Excel\SO Tests\" ' "E:\Excel Files\" 'Assign directory to MyFolder variable
MyFile = Dir(MyFolder) 'Dir gets the first file of the folder
MyValue = InputBox("Type the Value")
Application.ScreenUpdating = False
Matrice_size = 0
'Loop through all files until Dir cannot find anymore
' add only cells = MyValue to the Matrice array
Do While MyFile <> ""
Set wbk = Workbooks.Open(Filename:=MyFolder & MyFile)
Set wSht = wbk.Sheets("Sheet1")
'Sheets1.Activate
Dim1 = wSht.Range("A2", wSht.Range("A1").End(xlDown)).Cells.Count - 1
'Dim2 = wSht.Range("A1", wSht.Range("A1").End(xlToRight)).Cells.Count - 1
For i = 2 To Dim1
If wSht.Cells(i, 1) = MyValue Then
ReDim Preserve Matrice(0 To Matrice_size)
Matrice(Matrice_size) = wSht.Cells(i, 1).Offset(0, 1).Value
Matrice_size = Matrice_size + 1
End If
Next i
wbk.Close savechanges:=True
MyFile = Dir 'Dir gets the next file in the folder
Loop
' copy the array to Sheet1 in this workbook, starting from Cell A2 >> can modify to your needs
ThisWorkbook.Worksheets("Sheet1").Range("A2").Resize(UBound(Matrice) + 1).Value = Application.Transpose(Matrice)
Application.ScreenUpdating = True
End Sub
I used a combination of Filter and RemoveDuplicates.
Sub ImportUniqueData()
Const MyFolder = "E:\Excel Files\"
Dim xlWB As Workbook
Dim NextRow As Long
Dim MyFile As String, MyValue As String
Dim FilteredData As Range
MyFile = Dir(MyFolder & "*.xlsx")
MyValue = InputBox("Type the Value")
Do Until MyFile = ""
NextRow = Range("A" & Rows.Count).End(xlUp).Row + 1
Set xlWB = Workbooks.Open(Filename:=MyFolder & MyFile)
With xlWB.Worksheets(1)
.Rows(1).AutoFilter Field:=1, Criteria1:=MyValue
Set FilteredData = .Range("A1").CurrentRegion.Offset(1).SpecialCells(xlCellTypeVisible)
FilteredData.Copy ThisWorkbook.ActiveSheet.Cells(NextRow, 1)
End With
xlWB.Close SaveChanges:=False
MyFile = Dir
Loop
ActiveSheet.UsedRange.RemoveDuplicates
End Sub
My requirement is
1) To open a existing Excel workbook
2) Identify the next empty row and enter time stamp to that row
3) Save and Close the Excel work book
To achieve this I used below code:
Sub UpdateReport()
Dim directory As String, fileName As String
Dim FirstBlankCell As Range
Application.ScreenUpdating = False
directory = "C:\Users\Desktop\Excel_sheets\"
fileName = Dir(directory & "Reports.xls")
Set wbr = Workbooks.Open(directory & fileName, ReadOnly:=False)
Set FirstBlankCell = Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
FirstBlankCell.Activate
myTimeStamp = Format(Now, "yyyy-mm-dd_hhmmss")
FirstBlankCell.Value = myTimeStamp
wbr.Saved = True
'wbr.Close True
End Sub
Problem I am facing is this code updates the sheet only if its open and also it overwrites the values.
I want the time-stamp to be set in next empty cell rather than over writing the old cell without keeping the excel open
Following piece of code should fulfill your requirement:
Sub UpdateReport()
Dim directory As String, fileName As String
Dim FirstBlankCell As Range
directory = "C:\Users\raj.kamal\Documents"
fileName = "stack1.xlsx"
Application.ScreenUpdating = False
Set ExcelAppl = CreateObject("Excel.Application")
Set wb = Application.Workbooks.Open(directory & "/" & fileName, ReadOnly:=False)
wb.Activate
Set ws = wb.Worksheets(1)
Set FirstBlankCell = ws.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
myTimeStamp = Format(Now, "yyyy-mm-dd_hhmmss")
ws.Activate
FirstBlankCell = myTimeStamp
wb.Save
wb.Close
ExcelAppl.Quit
Set wb = Nothing
Set ExcelAppl = Nothing
End Sub