Thank you for anyone that helps me with this.
I have written some VBA on a PC, but my copywriters use a mac and the Macros do not work. I get a run time error 13 on the following code:
If Range("Home_EPIC_Flag_Count").Value = 0 Then
is what gets highlighted yellow when I debug
Private Sub Worksheet_Calculate()
' EPIC flag conditional testing macros
If Range("Home_EPIC_Flag_Count").Value = 0 Then
Me.Shapes("Home_EPIC_Flag").Visible = False
Else
Me.Shapes("Home_EPIC_Flag").Visible = True
End If
If Range("Rooms_EPIC_Flag_Count").Value = 0 Then
Me.Shapes("Rooms_EPIC_Flag").Visible = False
Else
Me.Shapes("Rooms_EPIC_Flag").Visible = True
End If
If Range("Dining_EPIC_Flag_Count").Value = 0 Then
Me.Shapes("Dining_EPIC_Flag").Visible = False
Else
Me.Shapes("Dining_EPIC_Flag").Visible = True
End If
If Range("Spa_EPIC_Flag_Count").Value = 0 Then
Me.Shapes("Spa_EPIC_Flag").Visible = False
Else
Me.Shapes("Spa_EPIC_Flag").Visible = True
End If
If Range("Golf_EPIC_Flag_Count").Value = 0 Then
Me.Shapes("Golf_EPIC_Flag").Visible = False
Else
Me.Shapes("Golf_EPIC_Flag").Visible = True
End If
If Range("LocalArea_EPIC_Flag_Count").Value = 0 Then
Me.Shapes("LocalArea_EPIC_Flag").Visible = False
Else
Me.Shapes("LocalArea_EPIC_Flag").Visible = True
End If
If Range("Business_EPIC_Flag_Count").Value = 0 Then
Me.Shapes("Business_EPIC_Flag").Visible = False
Else
Me.Shapes("Business_EPIC_Flag").Visible = True
End If
A little refactoring will make your code more manageable (once you fix the named range issue)
Private Sub Worksheet_Calculate()
Dim arr, x As Long
arr = Array("Home", "Rooms", "Dining", "Spa", "Golf", "LocalArea", "Business")
For x = LBound(arr) To UBound(arr)
Me.Shapes(arr(x) & "_EPIC_Flag").Visible = _
(Range(arr(x) & "_EPIC_Flag_Count").Value > 0)
Next x
End Sub
Related
I am learning through the internet and based on my knowledge and data available on the internet, I have created the following macro which works. The purpose of the macro is to filter the data, arrange it in the desired format and print it.
The problem is, once I run the macro, all the filters are printed in one pass. I am looking for a change where after running the macro, I get a display to select the filter I want to print or if I want to print all the filters.
I hope I was able to explain my problem. Let me know if anyone can help me. Thanks
Sub itemno()
ThisWorkbook.Worksheets("Sheet1").Activate
Dim LR As Long
Dim Sh As Worksheet
Set Sh = Worksheets("Sheet1")
LR = Sh.Range("H" & Rows.Count).End(xlUp).Row
Sh.Range("P2:P" & LR).Formula = "=IF(LEFT(RC[-13],3)=""300"",RIGHT(RC[-7],4)&""-""&RIGHT(RC[-14],3),RC[-13])"
Sh.Range("P1:P" & LR).Copy
Sh.Columns("B:B").Select
Selection.PasteSpecial Paste:=xlPasteValues
Sh.Columns("C:C").Delete
Sh.Columns("F:F").Delete
Sh.Columns("I:P").Delete
Sh.Range("A1").FormulaR1C1 = "Colli Nr."
Sh.Range("B1").FormulaR1C1 = "Item Nr."
Sh.Range("D1").FormulaR1C1 = "Unit"
Sh.Cells.Select
Sh.Cells.EntireColumn.Autofit
Sh.Columns("A:A").ColumnWidth = 20
Sh.Columns("C:C").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlTop
End With
Selection.NumberFormat = "0.0"
Sh.Cells.Select
Selection.RowHeight = 25
With Selection
.VerticalAlignment = xlCenter
End With
Sh.Rows("1:1").Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Sh.Columns("F:F").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Sh.Range("F1").Select
ActiveCell.FormulaR1C1 = "Bemerkung"
Sh.Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Selection.Font.Bold = True
With Selection.Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Sh.Columns("E:E").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Sh.Range("E1").FormulaR1C1 = "CheckBox"
Sh.Range("M2:M" & LR).Formula = "=RC[-10]&"" ""&RC[-9]"
Sh.Range("M1:M" & LR).Copy
Sh.Columns("C:C").Select
Selection.PasteSpecial Paste:=xlPasteValues
Sh.Range("C1").FormulaR1C1 = "Menge"
Sh.Columns("M:M").Delete
Sh.Columns("D:D").Delete
Dim cb As CheckBox
Dim myRange As Range, cel As Range
Dim wks As Worksheet
Set wks = Sheets("Sheet1")
Set myRange = wks.Range("D2:D" & LR)
For Each cel In myRange
Set cb = wks.CheckBoxes.Add(cel.Left, cel.Top, 30, 15)
With cb
.Caption = ""
.OnAction = "ProcessCheckBox"
End With
Next
Dim Rang As Range
Set Rang = Sh.Range("A1:I" & LR)
With Rang.Borders
.LineStyle = xlContinuous
.Color = vbBlack
.Weight = xlThin
End With
wks.Rows("1:7").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.RowHeight = 15
Sh.Range("A1:F1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Sh.Range("A1:F1").Select
ActiveCell.FormulaR1C1 = "Packliste nur für die Werkstatt"
Sh.Range("A3").Select
ActiveCell.FormulaR1C1 = "Projekt:"
Sh.Range("B3:D3").Select
With Selection
.HorizontalAlignment = xlLeft
End With
Selection.Merge
Sh.Range("E3").Select
ActiveCell.FormulaR1C1 = "Column Nr."
Sh.Range("A4").Select
ActiveCell.FormulaR1C1 = "Zeichnung Nr. "
Sh.Range("B4:C4").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Sh.Range("E4").Select
ActiveCell.FormulaR1C1 = "Dokument Nr."
Sh.Range("A6").Select
ActiveCell.FormulaR1C1 = "Verpackt von:"
Sh.Range("E6").Select
ActiveCell.FormulaR1C1 = "Geprüft von:"
Sh.Rows("1:1").Select
Selection.RowHeight = 20
Selection.Font.Bold = True
Selection.Font.Size = 16
Selection.Font.Underline = xlUnderlineStyleSingle
Sh.Columns("B:B").ColumnWidth = 20
Sh.Columns("D:D").ColumnWidth = 15
Sh.Columns("C:C").ColumnWidth = 12
Sh.Columns("F:F").ColumnWidth = 40
Sh.Columns("G:G").Cut
Sh.Columns("J:J").Insert Shift:=xlToRight
Sh.Activate
Dim Rng As Range
Dim c As Range
Dim List As New Collection
Dim Item As Variant
Application.ScreenUpdating = False
Set Rng = Sh.Range("G9:G" & Sh.Range("G65536").End(xlUp).Row)
On Error Resume Next
For Each c In Rng
List.Add c.Value, CStr(c.Value)
Next c
On Error GoTo 0
Set Rng = Sh.Range("G8:G" & Sh.Range("G65536").End(xlUp).Row)
For Each Item In List
Rng.AutoFilter Field:=1, Criteria1:=Item
Sh.Range("F4") = Item
Sh.Range("F3:F4").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
Sh.Range("F3").FormulaR1C1 = "=VLOOKUP(TEXT(R[1]C,0),C[1]:C[3],3,FALSE)"
Sh.Range("B4:C4").FormulaR1C1 = "=VLOOKUP(TEXT(RC[4],0),C[5]:C[7],2,FALSE)"
Sh.Range("B3:D3").FormulaR1C1 = "=LEFT(R[6]C,9)"
Application.PrintCommunication = False
Sh.Activate
ActiveSheet.PageSetup.PrintArea = "$A:$F"
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$8"
.LeftMargin = Application.InchesToPoints(0.236220472440945)
.RightMargin = Application.InchesToPoints(0.236220472440945)
.TopMargin = Application.InchesToPoints(0.2)
.BottomMargin = Application.InchesToPoints(0.35)
.HeaderMargin = Application.InchesToPoints(0.2)
.FooterMargin = Application.InchesToPoints(0.35)
.Orientation = xlLandscape
.PaperSize = xlPaperA4
.LeftFooter = "Colli-Informationen eingeben (Abmessungen, Bruttogewicht & Tara)"
.RightFooter = "&P/&N"
End With
Application.PrintCommunication = True
Sh.PrintOut
Rng.AutoFilter
Next Item
Application.ScreenUpdating = True
End Sub
I keep getting an error 1004 for the line that has an asterisk. I am a complete beginner. How can I debug this?
There is more code before & after this, but everything else seems to be working properly.
Dim i As Long
i = 1
Do Until i = Range("Q1").Value - 1
ActiveCell.Offset(rowOffset:=2, columnOffset:=0).Activate
Range(ActiveCell, ActiveCell.Offset(0, 7)).Select
With Selection
.HorizontalAlignment = xlCenterAcrossSelection
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Font
.Name = "Inherit"
.Size = 14
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
Selection.Font.Bold = True
End With
ActiveCell.Offset(rowOffset:=2, columnOffset:=0).Activate
Selection.End(xlToRight).Select
**ActiveCell.Offset(rowOffset:=0, columnOffset:=1).Activate
ActiveCell.FormulaR1C1 = "Hours Optimized"
ActiveCell.Offset(rowOffset:=0, columnOffset:=1).Activate
ActiveCell.FormulaR1C1 = "FTE's Optimized"
ActiveCell.Offset(rowOffset:=0, columnOffset:=1).Activate
ActiveCell.FormulaR1C1 = "ROI"
ActiveCell.Offset(rowOffset:=0, columnOffset:=1).Activate
ActiveCell.FormulaR1C1 = "Months Payback"
Range(Selection, Selection.End(xlToLeft)).Select
I try to export to Excel with the fpsread plugin, but there really is no information on how, I have searched the manual but they only show me how to do it with .net
Will someone have an idea?
I managed to do it was very simple, but wanting to import the titles was the heaviest, but here I leave the code in case any work
Private Sub CmdImportar_Click()
Call Export_Excel(cdgExcel, sprFacturas)
Call HacerBusqueda
End Sub
Public Sub Export_Excel(cdgExcel As CommonDialog, Spread As fpSpread)
Dim Header() As String
Dim I As Integer
Dim j As Integer
Dim x As Integer
With cdgExcel
.CancelError = False
.InitDir = "C:/:"
.Filter = "Excel(*.xls)|*.xls"
.ShowSave
If .filename <> "" Then
Spread.Redraw = False
For I = 1 To Spread.ColHeaderRows
ReDim Header(Spread.MaxCols) As String
Spread.Row = SpreadHeader + (I - 1)
For j = 1 To Spread.MaxCols
Spread.Col = j
Header(j) = Spread.Text & ""
Next j
Spread.MaxRows = Spread.MaxRows + 1
Spread.Row = I
Spread.Action = ActionInsertRow
For j = 1 To Spread.MaxCols
Spread.Col = j
Spread.CellType = Spread.CellType
Spread.TypeHAlign = Spread.TypeHAlign
Spread.TypeVAlign = Spread.TypeVAlign
Spread.Text = Header(j) & ""
Next j
Next I
x = Spread.ExportToExcel(.filename, "Sheet1", "")
For I = 1 To Spread.ColHeaderRows
Spread.Row = 1
Spread.Action = ActionDeleteRow
Next I
If x = True Then
MsgBox .filename & vbNewLine & "Se ha Importado el archivo", vbInformation, "Resultado"
Else
MsgBox "No se ha podido exportar el archivo", vbCritical, "Error"
End If
End If
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 have 'Applications.PrevInstance' in VB 6 code that I am trying to upgrade to .NET using VS 2008. Apparently this code is no longer valid. Does anyone have any ideas about upgraded solution? TIA
See here:
http://www.knowdotnet.com/articles/previnstance.html
Public Sub Main()
If PrevInstance() Then Exit Sub
' continue with your application
UserName = Environ("UserName")
ComputerName = Environ("COMPUTERNAME")
End Sub
Function PrevInstance() As Boolean
If UBound(Diagnostics.Process.GetProcessesByName _
(Diagnostics.Process.GetCurrentProcess.ProcessName)) _
> 0 Then
Return True
Else
Return False
End If
End Function
Function PrevInstance() As Boolean
If UBound(Diagnostics.Process.GetProcessesByName(Diagnostics.Process.GetCurrentProcess.ProcessName)) > 0 Then
PrevInstance = True
Else
UserName = Environ("UserName")
Computername = Environ("COMPUTERNAME")
PrevInstance = False
End If
Dim i, n As Integer, RepForm As String
For i = My.Application.OpenForms.Count - 1 To 1 Step -1
RepForm = My.Application.OpenForms.Item(i).Name
For n = My.Application.OpenForms.Count - 1 To 1 Step -1
If My.Application.OpenForms.Item(n).Name = My.Application.OpenForms.Item(i).Name And n > i Then
My.Application.OpenForms(i).Close()
PrevInstance = True
Exit Function
End If
Next n
Next i
End Function