I am using the following function to create a TableStyle:
Public Function CreateTableStyle()
ActiveWorkbook.Unprotect
Dim objTS As TableStyle
On Error Resume Next
Set objTS = ActiveWorkbook.TableStyles("MyTableStyle")
On Error GoTo err_CreateTableStyle
If Not objTS Is Nothing Then
Exit Function
End If
Set objTS = ActiveWorkbook.TableStyles.Add("MyTableStyle")
With ActiveWorkbook.TableStyles("MyTableStyle")
.ShowAsAvailablePivotTableStyle = True
.ShowAsAvailableTableStyle = False
End With
With ActiveWorkbook.TableStyles("MyTableStyle").TableStyleElements( _
xlHeaderRow).Font
.FontStyle = "Bold"
.TintAndShade = 0
.ThemeColor = xlThemeColorDark1
End With
With ActiveWorkbook.TableStyles("MyTableStyle").TableStyleElements( _
xlHeaderRow).Interior
.ThemeColor = xlThemeColorLight2
.TintAndShade = -0.249946592608417
End With
With ActiveWorkbook.TableStyles("MyTableStyle").TableStyleElements( _
xlTotalRow).Font
.FontStyle = "Bold"
.TintAndShade = 0
.ThemeColor = xlThemeColorDark1
End With
With ActiveWorkbook.TableStyles("MyTableStyle").TableStyleElements( _
xlTotalRow).Interior
.ThemeColor = xlThemeColorLight2
.TintAndShade = -0.249946592608417
End With
ActiveWorkbook.TableStyles("MyTableStyle").TableStyleElements( _
xlSubtotalRow1).Font.FontStyle = "Bold"
With ActiveWorkbook.TableStyles("MyTableStyle").TableStyleElements( _
xlSubtotalRow1).Interior
.Color = 16764828
.TintAndShade = 0
End With
ActiveWorkbook.TableStyles("MyTableStyle").TableStyleElements( _
xlSubtotalRow2).Font.FontStyle = "Bold"
With ActiveWorkbook.TableStyles("MyTableStyle").TableStyleElements( _
xlSubtotalRow2).Interior
.Color = 16777164
.TintAndShade = 0
End With
ActiveWorkbook.Protect
Exit Function
err_CreateTableStyle:
Call Common.ErrRaise(Erl, "Common", "CreateTableStyle", "CreateTableStyle")
End Function
At the line below:
With ActiveWorkbook.TableStyles("MyTableStyle").TableStyleElements( _
xlHeaderRow).Font
.FontStyle = "Bold"
I am getting an error:
Run-time error '1004'
Unable to set the FontStyle property of the Font class.
Can someone please identify the issue? I am not able to figure why it is not letting me set the property.
XLA's may behave differently some time .... they are loaded/executed when Excel starts, before any sheet (even an empty one) is opened, so an XLA asuming an open book will fail
If this code is intended to set some "default formattings" ...
... I would rather set up the formatting and save the whole sheet as a sheet or workbook template (XLT), then create new files using that template,
... or - again in a template, store the above code and call it from an event macro like Workbook_NewSheet() or Workbook_Open()
Try .font.bold = true
Related
I'm having a problem that has me stumped. After I copy a table from a PPTX file and paste it t another file and try to repsosition it, it fails. THe two message boxes after that are not working
here's the code and thanks in advance
Option Private Module
' Tables
Sub InsertTable(n As Integer)
Dim CurWindow As DocumentWindow
Dim SourceWindow As DocumentWindow
Dim LoadFrom As String
Dim LoadImage As Shapes
LoadFrom = "Tables.pptx"
'disable screen updating
Set appObject = New cScreenUpdating
appObject.ScreenUpdating = False
'' On Error GoTo Err_handler
With Application.ActiveWindow
If Not (.ViewType = ppViewNormal Or .ViewType = ppViewSlide) Then _
Application.ActiveWindow.ViewType = ppViewNormal
If .ActivePane.ViewType <> ppViewSlide Then .Panes(2).Activate
End With
Set CurWindow = Application.ActiveWindow
'load the library and copy the slide
LoadLibrary LoadFrom
LoadDiagram = ActivePresentation.Slides(n).Shapes.Paste(1)
With ActiveWindow.Selection
.Left = 335
.Top = 370
End With
If ActiveWindow.Selection.Type = ppSelectionShapes Then MsgBox "Shapes"
If ActiveWindow.Selection.Type = msoTable Then MsgBox "Tables"
ExitMe:
On Error Resume Next
SourceWindow.Close
Set CurWindow = Nothing
Set SourceWindow = Nothing
'' RefreshWindow
'enable screen updating
ScreenUpdating = True
Exit Sub
Err_handler:
MsgBox "Switch to Normal View.", vbInformation + vbOKOnly, strAppName
glbErr = True
Resume Err_Resume
Err_Resume:
On Error Resume Next
GoTo ExitMe
End Sub
(Edited significantly) this works, adapt as needed
Sub InsertTable()
Dim SourceFile As Presentation
Set SourceFile = Application.Presentations.Open("Tables.pptx", True, False, msoFalse)
SourceFile.Slides(1).Shapes("Table").Copy
ActivePresentation.Slides(1).Shapes.Paste.Select
With ActiveWindow.Selection.ShapeRange
.Left = 0
.Top = 0
End With
End Sub
I want to combine the functionalities of two codes. My first code is converting a csv file to an excel file and saving it with a different name.
I want to add a functionality of deleting the entire row in a file where column A is #N/A. There may be a small thing to fix it but I am not able to work
it out because I am not good at it.
file = "C:\PR\TEST\Sizetest.csv"
Set fso = CreateObject("Scripting.FileSystemObject")
txt = fso.OpenTextFile(file).ReadAll
fso.OpenTextFile(file, 2).Write Replace(Replace(txt, "¬", vbTab), Chr(34), "")
'Set obj = CreateObject("Scripting.FileSystemObject") 'Calls the File System Object
Const xlDelimited = 1
Const xlNormal = -4143
Dim Excel
Set Excel = CreateObject("Excel.Application")
With Excel
.Workbooks.Open "C:\PR\TEST\Sizetest.csv"
.Sheets(1).Columns("A").TextToColumns .Range("A1"), xlDelimited, , , , True 'semicolon-delimited
.ActiveWorkbook.SaveAs .ActiveWorkbook.Path & "\Size_test1", xlNormal
.Quit
' fso.DeleteFile("C:\PR\TEST\Sizetest.csv") 'Deletes the file throught the DeleteFile function
End With
This is the second code. This should delete entire row whereever there is #N/A in column A. I want the record to be deleted either before the file is
converted to Excel or after it is converted to Excel so it does not matter at what point it should convert it.
I got the following code by searching in the Google but due to not being good at VB script, I am not able to combine them two files. I tried different ways but I am getting one error or another.
Sub macro2()
Dim i As Long, lcol As Long
Application.DisplayAlerts = False
With Worksheets("Sheet1")
lcol = .Range("A1"). End(xLToRight).Column
For i = lcol To 1 Step -1
If.Cells(1, i).Value = "#N/A" Then .Rows(i).Delete
Next i
End With
Application.DisplayAlerts = True
End Sub
Thanks in advance
Updated Code Only to delete #N/A
Sub DeleteErrorRows()
'The path to the workbook in which to search.
'Defining the variables
Dim MyPath, MySheet,MyWB
MyPath = "C:\PR\TEST\Sizetest.xls"
'The name of the workbook in which to search.
MyWB = "SizeGuideLookup_test.xls"
'Use the current sheet as the place to store the data for which to search.
MySheet = ActiveSheet.Name
'If an error occurs, use the error handling routine at the end of this file.
'On Error GoTo ErrorHandler
'Turn off screen updating, and then open the target workbook.
'Application.ScreenUpdating = False
Const strERROR = "#N/A"
Application.ScreenUpdating = False
Dim i, lastRow, rw
Dim rFound
Dim sList
Workbooks.Open MyPath
'Workbooks.Open FileName:=MyPath & MyWB
set wb = Workbooks.Open(objFile.Mypath, ReadOnly:=True, CorruptLoad:=xlExtractData)
wb.Close
Set sList = CreateObject("System.Collections.Sortedlist")
Set rFound = ActiveSheet.Cells.Find(What:=strERROR, After:=Range("A1"), Lookat:=xlPart,LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If rFound Is Nothing Then Exit Sub
lastRow = rFound.Row
For i = 1 To lastRow
Set rFound = Rows(i).Find(What :=strERROR, After:=Rows(i).Cells(1, Columns.Count), Lookat:=xlPart, _
LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not rFound Is Nothing Then
If Not sList.ContainsKey(i) Then
sList.Add i, vbNullString
End If
End If
Next
For i = sList.Count - 1 To 0 Step -1
rw = sList.GetKey(i)
Rows(rw).Delete
Next
DeleteErrorRows
Application.ScreenUpdating = True
'conn.close
End Sub
I am getting error on the following line of code. Error says 'Expected End of Statement )' This code seems ok to me. There might be other errors and I am trying to get this program to work. Set rFound = ActiveSheet.Cells.Find(What:=strERROR, After:=Range("A1"), Lookat:=xlPart,LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
Delete all Rows with a #N/A Error from an Excel Worksheet using either VBA or VBScript
Sub RemoveErrorRows(oWorksheet)
Const strERROR = "#N/A"
Const xlValues = -4163
Const xlPart = 2
Const xlByRows = 1
Const xlNext = 1
Dim rFound, lastRow, x
With oWorksheet
Do
Set rFound = .Rows.Find(CStr(strERROR), .UsedRange.Cells(1, .Columns.Count), xlValues, xlPart, xlByRows, xlNext)
If rFound Is Nothing Then
Exit Do
Else
.Rows(rFound.Row).Delete
End If
Loop
End With
End Sub
I have a function that i am using to show crystal reports in my application. Everything was fine until yesterday afternoon and now it is showing nothing but a blank window. But it is not giving any error.In crystal report designer it is showing values while previewing. I am using stored procedure to retrieve values from DB. Here is my code
Public Sub ShowReport(ParamArray reportParameters())
On Error GoTo Catch
Dim NTOT As Integer
Dim nCtr As Integer
Dim LoopCount As Integer
Dim ReportPath As String
Open App.Path & "/Reports.txt" For Input As #1
Input #1, ReportPath
Close #1
ReportPath = ReportPath & "\Reports\" & reportParameters(0)
'MsgBox ReportPath
Screen.MousePointer = vbHourglass
With frmReports.Crpt
.Reset
.WindowTop = 0
.WindowLeft = 0
.ReportFileName = ReportPath
'.RetrieveStoredProcParams
For LoopCount = 3 To UBound(reportParameters)
.StoredProcParam(LoopCount - 3) = reportParameters(LoopCount)
Next
.WindowTitle = reportParameters(1)
.ReportTitle = reportParameters(1)
.WindowParentHandle = frmReports.hwnd
.WindowShowSearchBtn = True
.WindowShowPrintSetupBtn = True
.WindowShowRefreshBtn = True
.WindowShowProgressCtls = True
.WindowShowZoomCtl = True
.WindowShowGroupTree = True
.WindowAllowDrillDown = True
.ProgressDialog = True
.PageZoom (100)
.WindowState = crptMaximized
If reportParameters(2) = "P" Then
.Destination = crptToPrinter
Else
.Destination = crptToWindow
End If
.Action = 1
End With
Screen.MousePointer = vbNormal
Exit Sub
Catch:
Screen.MousePointer = vbNormal
End Sub
I am using VB6 and crystal reports version is 8
what is wrong in this code? Can anyone find a solution for this
I am trying to import data from web to Excel worksheet on win 7.
But, I do not know how to finish the left one where is marked .
Sub Ex2Macro()
Ex2 from Macro1 Macro
' Macro changed 17/07/2007 by Dr. B. I. Czaczkes
Dim qt As QueryTable
Dim temp As Variant ' Double
Set qt = ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://finance.yahoo.com/q?s=GBPUSD=X", Destination:=ActiveCell.Range("A1"))
With qt
.Name = "query1"
.BackgroundQuery = False
.SaveData = True
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "14"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.Refresh BackgroundQuery:=False
End With
With qt.ResultRange
.ClearContents
.Range("a1").Value = "USD/GBP"
.Range("b1").Value = ? ' here, what I should put so that the queried result
' is printed ?
End With
End Sub
Another piece of code that provide the exchange result.
Sub Ex3Macro()
Dim qt As QueryTable
' Dim temp As Double
Dim temp As Variant
temp = ActiveCell.Value
Set qt = Worksheets("temp").QueryTables.Add(Connection:= _
"URL;http://finance.yahoo.com/currency/convert?amt=" & _
temp & _
"&from=USD&to=GBP&submit=Convert" _
, Destination:=Worksheets("Temp").Range("a1"))
With qt
.Name = "query2"
.BackgroundQuery = False
.SaveData = True
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "13"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.Refresh BackgroundQuery:=False
End With
ActiveCell.Range("b1").Value = qt.ResultRange.Range("e3").Value
End Sub
But, no result is printed.
Any help will be appreciated.
Try selecting the Microsoft WinHTTP Services, version 5.1 reference then using this:
Sub HTTPTest()
Dim httpRequest As WinHttpRequest
Dim URL As String, strHTML As String
If httpRequest Is Nothing Then
Set httpRequest = New WinHttp.WinHttpRequest
End If
URL = "http://finance.yahoo.com/q?s=GBPUSD=X"
httpRequest.Open "GET", URL, True
httpRequest.Send
httpRequest.WaitForResponse
strHTML = httpRequest.ResponseText
Set httpRequest = Nothing
'Parse strHTML now to get your value
End Sub
I have an auto-filtered range of data. The auto filter was created by the following VB code:
Sub Colour_filter()
Range("A4").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.AutoFilter
End Sub
I would like to sort the values in column "A" (the data actually start from cell "A4") by the following colour ( Color = RGB(255, 102, 204) ) so all the cells with that colour sort to the top.
It would be fab if the extra code could be added to my existing code?
My office is really noisy and my VB isn’t the best. It is doubly hard with laughing, chatting ladies all about. Any help will be stress relief heaven!! (p.s. no poke at the ladies it’s just my office is 95% women).
Edited per request by #ScottHoltzman.
My requested code forms part of a larger code which would confuse matters, although here is a slimmed down version of the aspect I currently need.
Sub Colour_filter()
' Following code( using conditional formatting) adds highlight to 'excluded' courses based
'on 'course code' cell value matching criteria. Courses codes matching criteria are highlighted
'in 'Pink'; as of 19-Nov-2012 the 'excluded' course codes are
'(BIGTEST, BIGFATCAT).
' <====== CONDITIONAL FORMATTING CODE STARTS HERE =======>
Columns("A:A").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""BIGTEST"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.Color = 13395711
End With
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""BIGFATCAT"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.Color = 13395711
End With
' <====== CONDITIONAL FORMATTING CODE ENDS HERE =======>
' Following code returns column A:A to Font "Tahoma", Size "8"
Columns("A:A").Select
With Selection.Font
.Name = "Tahoma"
.FontStyle = "Regular"
.Size = 8
.ThemeColor = xlThemeColorLight1
.ThemeFont = xlThemeFontNone
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.WrapText = False
End With
' Following code adds border around all contiguous cells ion range, similar to using keyboard short cut "Ctrl + A".
Range("A4").Select
ActiveCell.CurrentRegion.Select
With Selection
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
End With
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
' Following code adds 'Blue' cell colour to all headers in Row 4 start in Cell "A4".
Range("A4").Select
Range(Selection, Selection.End(xlToRight)).Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Selection.Font.Bold = True
'<== adds auto-filter to my range of cells ===>
Range("A4").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.AutoFilter
End Sub
Well here is a small Sub that does the following sorting as per shown image. Most of the values like dimensions/range sizes are very static since this is a sample. You may improve it to be dynamic. Please comment if this code is going in the right direction so I can update with the final sort.
EDITTED CODE WITH DOUBLE SORT KYES
code:
Option Explicit
Sub sortByColor()
Dim rng As Range
Dim i As Integer
Dim inputArray As Variant, colourSortID As Variant
Dim colourIndex As Long
Set rng = Sheets(1).Range("D2:D13")
colourIndex = Sheets(1).Range("G2").Interior.colorIndex
ReDim inputArray(1 To 12)
ReDim colourSortID(1 To 12)
For i = 1 To 12
inputArray(i) = rng.Cells(i, 1).Interior.colorIndex
If inputArray(i) = colourIndex Then
colourSortID(i) = 1
Else
colourSortID(i) = 0
End If
Next i
'--output the array with colourIndexvalues and sorting key values
Sheets(1).Range("E2").Resize(UBound(inputArray) + 1) = _
Application.Transpose(inputArray)
Sheets(1).Range("F2").Resize(UBound(colourSortID) + 1) = _
Application.Transpose(colourSortID)
'-sort the rows based on the interior colour
Application.DisplayAlerts = False
Set rng = rng.Resize(, 3)
rng.Sort Key1:=Range("F2"), Order1:=xlDescending, _
Key2:=Range("E2"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Application.DisplayAlerts = True
End Sub
output: