I have tried via a named range however for some reason the equation keeps changing automatically within the named range after I run the a macro. So I attempted to set the range within the macro itself.
I am writing a macro that will look through a slicer and save the 2 sheets as a PDF. The 2nd tab has pivot which area range will change each time a slicer changes. Can someone help me so that this will print to PDF dynamically?
Sub Loopexport()
Dim ws2 As Worksheet
Dim PT As PivotTable
'Hide non-printable sheets
Sheets("Overview").Visible = False
Sheets("KPExport").Visible = False
Set ws2 = Sheets("Id CUps")
Set PT = ws2.PivotTables(1)
'Set print areas
Sheets("Stats").PageSetup.PrintArea = "$A$1:$M$39"
ws2.PageSetup.PrintArea = PT.TableRange2 'this is where I am receiving the type mismatch. and the = "My named range" kept changing automatically at the end.
With Sheets("Id CUps").Columns("D:D")
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Print Regions
'Export N1
ActiveWorkbook.SlicerCaches("Slicer_Dt").VisibleSlicerItemsList = Array("[UserID].[Dept].&[N1]")
ChDir ("C:\My Docs\A\B\Export")
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:="C:\My Docs\A\B\Export\N1 - " & Format(Now(), "YYYY") & "M" & Format(Now(), "MM")
End Sub
ws2.PageSetup.PrintArea = PT.TableRange2.Address
Related
I have a problem. I am trying to get records from the data base to Excel and afterwards format the Excel file. If I implement the whole function then it will run fine on one occasion. But if I run it again it sometimes gives the runtime 91 error. I was going through the debugging and if I only have the first ApXl in the function the code will work fine with no issues. However, if I add more of the code to reformat the Excel sheet then it will eventually give me the run time 91 even though the variables are already declared. Below is part of my code with some of the formatting.
Public Function ExportToExcelEM(Numbcases, strObjectType As String, strObjectName As String, Optional strSheetName As String, Optional strFileName As String)
Dim rst As DAO.Recordset
Dim ApXL As Object
Dim xlWBk As Object
Dim xlWSh As Object
Dim intCount As Integer
Const xlToRight As Long = -4161
Const xlCenter As Long = -4108
Const xlBottom As Long = -4107
Const xlContinuous As Long = 1
Dim OBJ As Object
On Error GoTo ExportToExcel_Err
DoCmd.Hourglass True
Select Case strObjectType
Case "Table", "Query"
Set rst = CurrentDb.OpenRecordset(strObjectName, dbOpenDynaset, dbSeeChanges)
Case "Form"
Set rst = Forms(strObjectName).RecordsetClone
Case "Report"
Set rst = CurrentDb.OpenRecordset(Reports(strObjectName).RecordSource, dbOpenDynaset, dbSeeChanges)
End Select
If rst.RecordCount = 0 Then
MsgBox "No records to be exported.", vbInformation, GetDBTitle
DoCmd.Hourglass False
Else
On Error Resume Next
Set ApXL = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set ApXL = CreateObject("Excel.Application")
End If
Err.Clear
On Error GoTo ExportToExcel_Err
Set xlWBk = ApXL.Workbooks.Add
ApXL.Visible = False
Set xlWSh = xlWBk.Worksheets("Sheet1")
If Len(strSheetName) > 0 Then
xlWSh.Name = Left(strSheetName, 31)
End If
xlWSh.Range("A1").Select
Do Until intCount = rst.Fields.Count
ApXL.ActiveCell = rst.Fields(intCount).Name
ApXL.ActiveCell.Offset(0, 1).Select
intCount = intCount + 1
Loop
rst.MoveFirst
xlWSh.Range("A2").CopyFromRecordset rst
** ** ** With ApXL
.Range("A1").Select
.Range(.Selection, .Selection.End(xlToRight)).Select
.Selection.Interior.Pattern = xlSolid
.Selection.Interior.PatternColorIndex = xlAutomatic
.Selection.Interior.TintAndShade = -0.25
.Selection.Interior.PatternTintAndShade = 0
.Selection.Borders.LineStyle = xlNone
.Selection.AutoFilter
.Cells.EntireColumn.AutoFit
.Cells.EntireRow.AutoFit
.Range("B2").Select
.ActiveWindow.FreezePanes = True
.ActiveSheet.Cells.Select
.ActiveSheet.Cells.WrapText = False
.ActiveSheet.Cells.EntireColumn.AutoFit
.Visible = False
End With********
With ApXL
xlWSh.Rows(1).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End With
xlWBk.SaveAs FileName:=strFileName, FileFormat:=51
xlWBk.Close
Set xlWBk = Nothing
Set xlWSh = Nothing
Set ApXL = Nothing
' end of doing anything with excel
End If
rst.Close
Set rst = Nothing
DoCmd.Hourglass False
ExportToExcel_Exit:
DoCmd.Hourglass False
Exit Function
ExportToExcel_Err:
DoCmd.SetWarnings True
Set xlWBk = Nothing
Set xlWSh = Nothing
Set ApXL = Nothing
rst.Close
MsgBox Err.Description, vbExclamation, Err.Number
DoCmd.Hourglass False
Resume ExportToExcel_Exit
End Function
debugging: works once after adding more formatting in my code but then gives me a runtime 91 error. I added more code chunks to the code till it was the complete excel function I desired. Throughout the process it would give me the finish piece I wanted but afterwards gives me a runtime error 91.
After running procedure, check if instance of Excel is still showing in Task Manager. This can be result of using Active______ referencing. Use explicit reference instead.
When I compile your procedure, I get "Method or data member not found." error on each line in the xlWSh.Rows(1).Select block. Use With .Rows(1) instead.
Could probably perform this process without actually selecting anything. Use explicit Cells or Range reference: With .Range("A1:E1") - construct reference with variables.
Modified your code to apply and it works:
intCount = rst.Fields.Count
Set xlWSh = xlWBk.worksheets("Sheet1")
With xlWSh
If strSheetName <> "" Then .Name = Left(strSheetName, 31)
For x = 1 To intCount
.Cells(1, x).Value = rst(x - 1).Name
Next
.Range("A2").CopyFromRecordset rst
With .Range(.Cells(1, 1), .Cells(1, intCount))
.Interior.Pattern = xlSolid
.Interior.PatternColorIndex = xlAutomatic
.Interior.TintAndShade = -0.25
.Interior.PatternTintAndShade = 0
.Borders.LineStyle = xlNone
.AutoFilter
.EntireColumn.AutoFit
End With
With .Rows(1)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.shrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
.Rows.AutoFit
End With
ApXL.Windows(1).SplitColumn = 1
ApXL.Windows(1).SplitRow = 1
ApXL.Windows(1).FreezePanes = True
I wrote a Web Query macro to import financial statements from Yahoo Finance based on the value in cell A1. It was working seamlessly for the past few weeks, but suddenly, it no longer returns any data (but does not generate an error). If anyone has any insights, I would appreciate your guidance. I have posted the code below--thank you!
Sub ThreeFinancialStatements()
On Error GoTo Explanation
Rows("2:1000").Select
Selection.ClearContents
Columns("B:AAT").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.ClearContents
Dim inTicker As String
inTicker = Range("A1")
ActiveSheet.Name = UCase(inTicker)
GetFinStats inTicker
Exit Sub
Explanation:
MsgBox "Please make sure you type a valid stock ticker symbol into cell A1 and are not trying to create a duplicate sheet." & _
vbLf & " " & _
vbLf & "Also, for companies with different classes of shares (e.g. Berkshire Hathaway), use a hyphen to designate the ticker symbol instead of a period (e.g. BRK-A)." & _
vbLf & " " & _
vbLf & "Please also note that not every company has three years of financial statements, so data may appear incomplete or missing for some companies.", _
, "Error"
Exit Sub
End Sub
Sub GetFinStats(inTicker As String)
'
' GetBalSheet Macro
'
'
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://finance.yahoo.com/q/bs?s=" & inTicker & "+Balance+Sheet&annual", Destination:= _
Range("$D$1"))
.Name = "bs?s=PEP+Balance+Sheet&annual"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "9"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://finance.yahoo.com/q/is?s=" & inTicker & "+Income+Statement&annual", Destination _
:=Range("$J$1"))
.Name = "is?s=PEP+Income+Statement&annual"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "9"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://finance.yahoo.com/q/cf?s=" & inTicker & "+Cash+Flow&annual", Destination:= _
Range("$P$1"))
.Name = "cf?s=PEP+Cash+Flow&annual"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "9"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Range("A3").Select
ActiveCell.FormulaR1C1 = "Current Ratio"
Range("A4").Select
ActiveCell.FormulaR1C1 = "Quick Ratio"
Range("A5").Select
ActiveCell.FormulaR1C1 = "Cash Ratio"
Range("A6").Select
Range("A7").Select
ActiveCell.FormulaR1C1 = "Revenue Growth Rate"
Range("A9").Select
Columns("A:A").ColumnWidth = 21.86
ActiveCell.FormulaR1C1 = "ROA"
Range("A10").Select
ActiveCell.FormulaR1C1 = "ROE"
Range("A11").Select
ActiveCell.FormulaR1C1 = "ROIC"
Range("B3").Select
ActiveCell.Formula = "=F11/F28"
Range("B4").Select
ActiveCell.Formula = "=(F11-F8)/F28"
Range("B5").Select
ActiveCell.Formula = "=F5/F28"
Range("B7").Select
ActiveCell.Formula = "=(L2/N2)^(1/2)-1"
Range("B9").Select
ActiveCell.Formula = "=L35/SUM(F12:F18)"
Range("B10").Select
ActiveCell.Formula = "=L35/F47"
Range("B11").Select
ActiveCell.Formula = "=L35/(F47+SUM(F29:F33))"
Range("B3").Select
Selection.NumberFormat = "0.00"
Range("B4").Select
Selection.NumberFormat = "0.00"
Range("B5").Select
Selection.NumberFormat = "0.00"
Range("B7").Select
Selection.NumberFormat = "0.00%"
Range("B9").Select
Selection.NumberFormat = "0.00%"
Range("B10").Select
Selection.NumberFormat = "0.00%"
Range("B11").Select
Selection.NumberFormat = "0.00%"
Range("A1").Select
End Sub
Your code is obviously working against a specific worksheet:
Rows("2:1000").Select
But what sheet is that? Only you can know that.
As written, it's whatever the active worksheet is, regardless of how much sense that makes.
Unqualified, these functions all implicitly refer to the ActiveSheet:
Range
Cells
Columns
Rows
Names
So you need to qualify them. And you do that by specifying a specific Worksheet object they should be working with - suppose that's DataSheet (I've no idea):
DataSheet.Rows("2:1000").Select
That would .Select the specified rows on the worksheet pointed to by the DataSheet object.
By why do you need to .Select it? This:
Rows("2:1000").Select
Selection.ClearContents
Could just as well be:
DataSheet.Rows("2:1000").ClearContents
Or better - assuming your data is formatted as a table (seems it looks like one anyway - so why not use the ListObjects API?):
DataSheet.ListObjects("DataTable").DataBodyRange.Delete
Sounds like that instruction has just replaced all the .Select and .ClearContents going on here. Note that .Select mimicks user action - the user clicking on a cell (or anything really) and selecting it. You have programmatic access to the entire object model - you never need to .Select anything!
Dim inTicker As String
inTicker = Range("A1")
Here you're implicitly reading from the active sheet, but you're also implicitly converting a Variant (the cell's value) into a String, which may or may not succeed. If A1 contains an error value (e.g. #REF!), the instruction fails.
With DataSheet.Range("A1")
If Not IsError(.Value) Then
inTicker = CStr(.Value)
Else
'decide what to do then
End If
End With
Your error-handling subroutine should at least Debug.Print Err.Number, Err.Description so that you have a bit of a clue about why things blew up. Right now it's assuming a reason for failure, and as you saw, Excel is full of traps.
Also you're using vbLf, but that's only half of a proper Windows newline character. Use vbNewLine if you're not sure what that is.
An Exit Sub instruction just before an End Sub token is completely useless.
Sub GetFinStats(inTicker As String)
The procedure is implicitly Public, and inTicker is implicitly passed ByRef. Kudos for giving it an explicit type!
This would be better:
Private Sub GetFinStats(ByVal inTicker As String)
With ActiveSheet.QueryTables
At least that's explicit about using the active sheet. But should it use the active sheet, or a specific sheet? And what happens to the query tables that were already there?
I strongly recommend you type this in the immediate pane:
?ThisWorkbook.Connections.Count
If the number is greater than the number of .QueryTables.Add calls you have in your procedure (likely), you have quite a problem there: I suspect you have over a hundred connections in the workbook, and clicking the "Refresh All" button takes forever to finish, and it's fairly possible that finance.yahoo.com is receiving dozens of requests from a single IP in a very limited amount of time, and refuses to serve them.
Delete all unused workbook connections. And then fix the implicit ActiveSheet references there too, and get rid of all these useless .Select calls:
With TheSpecificSheet
With .QueryTables.Add( ... )
End With
With .QueryTables.Add( ... )
End With
With .QueryTables.Add( ... )
End With
'assgin .Value, not .FormulaR1C1; you're not entering a R1C1 formula anyway
.Range("A3").Value = "Current Ratio"
.Range("A4").Value = "Quick Ratio"
.Range("A5").Value = "Cash Ratio"
End With
Consecutive .Select calls mean all but the last one serve a purpose, if any:
Range("A6").Select
Range("A7").Select
Again, don't assign ActiveCell when you can assign .Range("A7").Value directly.
And you can set number formats for a range of cells:
.Range("B3:B11").NumberFormat = "0.00%"
You can still retrieve the necessary data by parsing JSON response either from
https://finance.yahoo.com/quote/AAPL/financials(extracting data from HTML content, AAPL here just for example)
or via API
https://query1.finance.yahoo.com/v10/finance/quoteSummary/AAPL?lang=en-US®ion=US&modules=incomeStatementHistory%2CcashflowStatementHistory%2CbalanceSheetHistory%2CincomeStatementHistoryQuarterly%2CcashflowStatementHistoryQuarterly%2CbalanceSheetHistoryQuarterly%2Cearnings
You may use the below VBA code to parse response and output result. Import JSON.bas module into the VBA project for JSON processing. Here are Sub Test_query1_finance_yahoo_com() to get data via API and Test_finance_yahoo_com_quote to extract data from HTML content:
Option Explicit
Sub Test_query1_finance_yahoo_com()
Dim sSymbol As String
Dim sJSONString As String
Dim vJSON As Variant
Dim sState As String
sSymbol = "AAPL"
' Get JSON via API
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://query1.finance.yahoo.com/v10/finance/quoteSummary/" & sSymbol & "?lang=en-US®ion=US&modules=incomeStatementHistory%2CcashflowStatementHistory%2CbalanceSheetHistory%2CincomeStatementHistoryQuarterly%2CcashflowStatementHistoryQuarterly%2CbalanceSheetHistoryQuarterly%2Cearnings", False
.Send
sJSONString = .ResponseText
End With
' Parse JSON response
JSON.Parse sJSONString, vJSON, sState
If sState = "Error" Then
MsgBox "Invalid JSON"
Exit Sub
End If
' Pick core data
Set vJSON = vJSON("quoteSummary")("result")(0)
' Output
QuoteDataOutput vJSON
MsgBox "Completed"
End Sub
Sub Test_finance_yahoo_com_quote()
Dim sSymbol As String
Dim sJSONString As String
Dim vJSON As Variant
Dim sState As String
sSymbol = "AAPL"
' Get webpage HTML response
With CreateObject("Msxml2.XMLHTTP")
.Open "GET", "https://finance.yahoo.com/quote/" & sSymbol & "/financials", False
.Send
sJSONString = .ResponseText
End With
' Extract JSON from HTML content
sJSONString = "{" & Split(sJSONString, "root.App.main = {")(1)
sJSONString = Split(sJSONString, "}(this));")(0)
sJSONString = Left(sJSONString, InStrRev(sJSONString, "}"))
' Parse JSON response
JSON.Parse sJSONString, vJSON, sState
If sState = "Error" Then
MsgBox "Invalid JSON"
Exit Sub
End If
' Pick core data
Set vJSON = vJSON("context")("dispatcher")("stores")("QuoteSummaryStore")
' Output
QuoteDataOutput vJSON
MsgBox "Completed"
End Sub
Sub QuoteDataOutput(vJSON)
Const Transposed = True ' Output option
Dim oItems As Object
Dim vItem
Dim aRows()
Dim aHeader()
' Fetch main structures available from JSON object to dictionary
Set oItems = CreateObject("Scripting.Dictionary")
With oItems
.Add "IncomeStatementY", vJSON("incomeStatementHistory")("incomeStatementHistory")
.Add "IncomeStatementQ", vJSON("incomeStatementHistoryQuarterly")("incomeStatementHistory")
.Add "CashflowY", vJSON("cashflowStatementHistory")("cashflowStatements")
.Add "CashflowQ", vJSON("cashflowStatementHistoryQuarterly")("cashflowStatements")
.Add "BalanceSheetY", vJSON("balanceSheetHistory")("balanceSheetStatements")
.Add "BalanceSheetQ", vJSON("balanceSheetHistoryQuarterly")("balanceSheetStatements")
.Add "EarningsChartQ", vJSON("earnings")("earningsChart")("quarterly")
.Add "FinancialsChartY", vJSON("earnings")("financialsChart")("yearly")
.Add "FinancialsChartQ", vJSON("earnings")("financialsChart")("quarterly")
End With
' Output each data set to separate worksheet
For Each vItem In oItems
' Convert each data set to array
JSON.ToArray oItems(vItem), aRows, aHeader
' Output array to worksheet
With GetSheet((vItem))
.Cells.Delete
If Transposed Then
Output2DArray .Cells(1, 1), WorksheetFunction.Transpose(aHeader)
Output2DArray .Cells(1, 2), WorksheetFunction.Transpose(aRows)
Else
OutputArray .Cells(1, 1), aHeader
Output2DArray .Cells(2, 1), aRows
End If
.Columns.AutoFit
End With
Next
End Sub
Function GetSheet(sName As String, Optional bCreate = True) As Worksheet
On Error Resume Next
Set GetSheet = ThisWorkbook.Sheets(sName)
If Err Then
If bCreate Then
Set GetSheet = ThisWorkbook.Sheets.Add(, ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
GetSheet.Name = sName
End If
Err.Clear
End If
End Function
Sub OutputArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize(1, UBound(aCells) - LBound(aCells) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
Sub Output2DArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize( _
UBound(aCells, 1) - LBound(aCells, 1) + 1, _
UBound(aCells, 2) - LBound(aCells, 2) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
Finally Sub QuoteDataOutput(vJSON) input is a JSON object, to make it clear how the necessary data is being extracted from it, you may save the JSON string to file, copy the contents and paste it to any JSON viewer for further study. I use online tool http://jsonviewer.stack.hu, target element structure is shown below:
The output for me is as follows (first worksheet shown):
There are 9 main sections, the relevant part of the data is extracted and output to 9 worksheets:
IncomeStatementY
IncomeStatementQ
CashflowY
CashflowQ
BalanceSheetY
BalanceSheetQ
EarningsChartQ
FinancialsChartY
FinancialsChartQ
Having that example you can extract the data you need from that JSON response.
It turns out that Yahoo ended the application from which the web query drew its data. Thank you for all your tips.
I am trying to modify code from http://www.ozgrid.com/forum/showthread.php?t=174699
which looks in all word documents in a folder and returns an 'x' in columns if a searched value is found.
The column names are the documents in the folder. The row names are the searched strings.
I would like the routine to return rather a value or a string that is found in a word document to the right or next to the searched strings.
This would be a great tool to collect dates, invoice values, names etc. from unstructured data in word documents to excel table.
With oDOC.Content.Find
.ClearFormatting
.Text = rCell.Value
.MatchCase = False
.MatchWholeWord = False
.Execute
If .Found Then
'Sheet1.Cells(rCell.Row, lngCol).Value = "x" , returns an "x" if the word is found.
End If
End With
The complete code looks as follows:
Public Sub SearchDocs()
Dim oWRD As Object '** Word.Application
Dim oDOC As Object '** Word.Document
Dim oFound As Object '** Word.Range
Dim rCell As Excel.Range
Dim lngCol As Long
Dim strFile As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
lngCol = 1
'** Set oWRD = New Word.Application
Set oWRD = CreateObject("Word.Application")
oWRD.Visible = True
'// XL2007 specific
Sheet1.Range("B2:XFD100000").ClearContents
strFile = Dir$(Sheet1.Range("B1").Value & "\*.doc?")
lngCol = 2
'// loop matching files
Do While strFile <> vbNullString
'open
Set oDOC = oWRD.Documents.Open(Sheet1.Range("B1").Value & "\" & strFile)
With Sheet1.Cells(2, lngCol)
.Value = strFile
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 90
.EntireColumn.ColumnWidth = 3.35
End With
For Each rCell In Sheet1.Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)
With oDOC.Content.Find
.ClearFormatting
.Text = rCell.Value
.MatchCase = False
.MatchWholeWord = False
.Forward = False
.Execute
If .Found Then
'Selection.Collapse wdCollapseEnd
'Selection.Expand wdWord
'Sheet1.Cells(rCell.Row, lngCol).Value = "x"
'Sheet1.Cells(rCell.Row, lngCol).Value = .Text
Sheet1.Cells(rCell.Row, lngCol).Value = .Parent.Selection.Text
End If
End With
Next
Application.ScreenUpdating = True
DoEvents
Application.ScreenUpdating = False
lngCol = lngCol + 1
oDOC.Close
'// get next file
strFile = Dir$()
Loop
MsgBox "Finshed...", vbInformation
ErrHandler:
Application.ScreenUpdating = True
oWRD.Application.Quit
End Sub
I am not able to find in the net, or figure out, how to return a range of the found text and then offset it to return the text/value to the right. I am aware that offset exists in vba excel. But how to offset the range of the found string and return the value found in this offset range to excel?
This approach might work. Start by initializing a Range object to the range you want to search
Set oFound = oDOC.Content
Then instead of With oDOC.Content.Find do
With oFound.Find
When .Found = True, oFound will be moved to the found text. You can then move oFound by 1 word with something like:
With oFound
.MoveEnd Unit:=wdWord, Count:=1
.MoveStart Unit:=wdWord, Count:=1
End With
You can adjust Unit and Count per your requirements. Depending on your needs the related range object methods MoveEndUntil, MoveEndWhile, MoveStartUntil and MoveStartWhile may give better functionality. Check out these and other Range.Move methods here.
Hope that helps
The credit goes to xidgel. Thanks so much. It works like a charm.
The edited code, according to xidgel's direction may be of help to others, let me paste it:
Public Sub SearchDocs()
Dim oWRD As Object '** Word.Application
Dim oDOC As Object '** Word.Document
Dim oFound As Object '** Word.Range
Dim rCell As Excel.Range
Dim lngCol As Long
Dim strFile As String
'On Error GoTo ErrHandler
Application.ScreenUpdating = False
lngCol = 1
'** Set oWRD = New Word.Application
Set oWRD = CreateObject("Word.Application")
oWRD.Visible = True
'// XL2007 specific
Sheet1.Range("B2:XFD100000").ClearContents
strFile = Dir$(Sheet1.Range("B1").Value & "\*.doc?")
lngCol = 2
'// loop matching files
Do While strFile <> vbNullString
'open
Set oDOC = oWRD.Documents.Open(Sheet1.Range("B1").Value & "\" & strFile)
Set oFound = oDOC.Content
With Sheet1.Cells(2, lngCol)
.Value = strFile
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 90
.EntireColumn.ColumnWidth = 3.35
End With
For Each rCell In Sheet1.Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)
With oFound.Find 'With oDOC.Content.Find
Debug.Print rCell.Value
.ClearFormatting
.Text = rCell.Text
.MatchCase = False
.MatchWholeWord = False
.Forward = True
.MatchWildcards = True
.Wrap = wdFindContinue
.Execute
Debug.Print .Found
If .Found Then
With oFound
.Collapse wdCollapseEnd
.Expand wdWord
.MoveStart Unit:=wdWord, Count:=1
.MoveEnd Unit:=wdWord, Count:=5
End With
Sheet1.Cells(rCell.Row, lngCol).Value = oFound.Text
Debug.Print oFound.Text
End If
End With
Next
Application.ScreenUpdating = True
DoEvents
Application.ScreenUpdating = False
lngCol = lngCol + 1
oDOC.Close
'// get next file
strFile = Dir$()
Loop
MsgBox "Finshed...", vbInformation
ErrHandler:
Application.ScreenUpdating = True
oWRD.Application.Quit
End Sub
I want to loop through 2000 csv files, convert them to xls, make changes to the spreadsheet.
I can't work out how to save and close the workbook before moving on to the next.
I tried the following at the end of the script.
Application.ActiveWindow.Close SaveChanges:=False
ActiveWorkbook.Close SaveChanges:=False
I get a Minor loss of fidelity message.
The full code
Sub batchconvertcsvxls()
Dim wb As Workbook
Dim strFile As String, strDir As String, strOut_Dir As String, myNewFileName As String
strDir = "C:\csv\" 'location of csv files
strOut_Dir = "C:\converted\" 'location of xls files
strFile = Dir(strDir & "*.csv")
Do While strFile <> ""
Set wb = Workbooks.Open(filename:=strDir & strFile, Local:=True)
With wb
.SaveAs strOut_Dir & Replace(wb.Name, ".csv", ".xls"), 56
.Close True
End With
Set wb = Nothing
Set wb = Workbooks.Open(filename:=strOut_Dir & Replace(strFile, ".csv", ".xls"))
Rows("1:1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark2
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
Selection.RowHeight = 60
Selection.ColumnWidth = 30
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("E:E").Select
With Selection
.HorizontalAlignment = xlLeft
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Cells.Select
Selection.AutoFilter
Range("E2").Select
ActiveWindow.FreezePanes = True
For i = 1 To ActiveSheet.UsedRange.Columns.Count
DataFound = False
j = 2
While DataFound = False And j <= ActiveSheet.UsedRange.Rows.Count
If Cells(j, i).Value <> "" Then
DataFound = True
End If
j = j + 1
Wend
If DataFound = False Then
Columns(i).Hidden = True
End If
Next
strFile = Dir
Application.ActiveWindow.Close SaveChanges:=True ActiveWorkbook.Close
SaveChanges:=False
Loop
End Sub
You can try wb.Close SaveChanges:=False since you have set the workbook as wb that may get it to close without the message box popping up.
Also you can try Application.DisplayAlerts = False(this goes at the start of your code), it stops most types of messages popping up (there are some errors that cannot be stopped though(I dont have a list to hand but "out of memory" is an error that cannot be prevented for instance)).
I'll look into it a bit more sine im doing this off the top of my head and update the post if I get any more
I have 100 .txt files. Each .txt is connected to a different sheet in the workbook. I would like to name the sheet based on the name of .txt file connected in that sheet.
Here are some code.
Unfortunately they do not work as I got the error: "name already taken"
Sub MultipleTextFilesIntoExcelSheets()
Dim i As Integer 'a counter to loop through the files in the folder
Dim fname As String, FullName As String 'fname is the name of the file, and FullName is the name of its path
Dim ws As Worksheet 'a workbook object for the workbook where the current macro is running
''' Delete existing data connections
''''''''''''''''''''''''''''''''''''
Do While ActiveWorkbook.Connections.Count > 0
ActiveWorkbook.Connections.Item(ActiveWorkbook.Connections.Count).Delete
Loop
''' Rename raw data sheets to default string
''''''''''''''''''''''''''''''''''''''''''''
i = 1
For Each ws In Worksheets
If ws.Name Like "Test1" Or ws.Name Like "Test2*" = True Then
'Do Nothing
ElseIf ws.Name Like "Test1" Or ws.Name Like "Test2*" = False Then
ws.Name = "Sheet" & i
i = i + 1 'get ready for the next iteration
End If
Next ws
''' Import .txt files
'''''''''''''''''''''
i = 0
'get the name of the first text file
fname = Dir("C:\Sample\Test\*txt")
'loop through the text files to put them onto separate sheets in the Excel book
While (Len(fname) > 0)
'get the full path of the text file
FullName = "C:\Sample\Test\" & fname
i = i + 1 'get ready for the next iteration
Set ws = ThisWorkbook.Sheets("Sheet" & i) 'the current sheet
With ws.QueryTables.Add(Connection:="TEXT;" & FullName, Destination:=ws.Range("A1"))
.Name = fname
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True 'we are using a tab-delimited file
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
fname = Dir
End With
Wend
''' Rename sheets to new string
'''''''''''''''''''''''''''''''
For Each ws In Worksheets
If ws.Name Like "Test1" Or ws.Name Like "Test2*" = True Then
'Do Nothing
ElseIf (ws.Name Like "Test1" Or ws.Name Like "Test2*" = False) Then
ws.Name = Left(fname, (Len(fname) - 4))
End If
Next ws
End Sub
Thank you in advance,
Fede
You use Dir once to put an initial value into fname but then never change this initial value. In the second pass through the loop you are still using the same fname, hence Excel complains that you are using a name that is already taken.
It might work to insert the line fname = Dir right before Next ws. This would seem to be what you want, though I am uncomfortable with the overall logic of your code since it isn't clear how it guarantees that the right name goes with the right sheet. It might make more sense to write a sub that starts with an initially empty workbook and iterates through the folder importing the data and naming the sheets in one pass.
Also -- I think the logic of your ElseIf is murky. For one thing -- why not a simple Else?
If I understand correctly you will need to move the renaming of the sheets into your while loop prior to updating fname. (Update the sheet when you already know which sheet needs to be renamed)