Programmering Frågor & Svar

Nr 100

F: Hur tar jag enklast bort rader med ett visst innehåll i ett kalkylblad?

S: Följande procedur visar på ett möjligt sätt:

Sub Ta_Bort()

Dim rnText As Range

Set rnText = Cells.Find("Dennis", MatchCase:=False, _

LookAt:=xlPart, LookIn:=xlValues)

If Not rnText Is Nothing Then

rnText.EntireRow.Delete

End If

Loop Until rnText Is Nothing

End Sub

Nr 99

F: Jag ska till att installera ett tilläggsverktyg. Hur tar jag reda på sökvägen till Excels mapp för tilläggsverktyg?

S: Följande exempel visar sökvägen:

Sub Sokvag_Add_Ins_()

MsgBox Application.UserLibraryPath

End Sub

Nr 98

F: I en cell har jag en sträng av värden, såsom 1,2,3,4, vilken jag vill dela upp och få presenterad i separata celler i raden.

Sub Dela_Varde()

Dim rnData As Range

Dim vaData As Variant

Dim i As Long

Set rnData = ActiveSheet.Range("A1")

vaData = (Split(rnData, ","))

rnData.Resize(1, UBound(vaData) + 1).Value = vaData

End Sub

Nr 97

F: I en textruta i ett formulär vill jag att det inmatade värdet ska omvandlas till valuta.

S: En lösning är följande kod:

Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
   '© 2002 Alla rättigheter XL-Dennis
   With TextBox1
      .Text = FormatCurrency((.Text) * 1, NumDigitsAfterDecimal:=2)
   End With
End Sub

Om lösningen ska användas i olika språkversioner av Excel rekommenderas följande lösning istället:

Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)

With TextBox1

.Value = Format(CDbl(TextBox1.Text), "Currency")

End With

End Sub

Nr 96

F: Hur gör jag för att alltid markera sista cellen i ett arbetsblad?

S: Ett möjlighet är följande kod:

Sub Sista_Cellen()

Range("A1").SpecialCells(xlCellTypeLastCell).Select

End Sub

Nr 95

F: Hur kan jag omvandla text till versaler respektive gemener i VBA?

S: Beroende på vad du vill göra så visar följande procedurer vissa möjligheter:

Option Explicit

Sub Versal_Forsta_Tecknet()

Dim rnCell As Range

Set rnCell = ActiveSheet.Range("A1")

rnCell.Value = StrConv(rnCell.Value, vbProperCase)

End Sub

Sub Versaler_Alla_Tecken()

Dim rnCell As Range

Set rnCell = ActiveSheet.Range("A1")

rnCell.Value = StrConv(rnCell.Value, vbUpperCase)

End Sub

Sub Gemener_Alla_Tecken()

Dim rnCell As Range

Set rnCell = ActiveSheet.Range("A1")

rnCell.Value = StrConv(rnCell.Value, vbLowerCase)

End Sub

Nr 94

F: Hur kontrollerar jag det aktiva fönstret i XL?

S: Följande möjligheter finns:

Option Explicit

Sub Minimera_XL()

Application.WindowState = xlMinimized

End Sub

Sub Maximera_XL()

Application.WindowState = xlMaximized

End Sub

Sub Standard_XL()

Application.WindowState = xlNormal

End Sub

Nr 93

F: Använder mig av kontroller i ett arbetsblad, vilka hämtas från verktygsfältet Kontroller. Hur ska jag göra för att fylla t ex en combobox med värden?

S: Det krävs ett speciell anrop till objektet såsom följande visar:

Sub Tilldela_ComboBox_Arbetsblad_Varden()

Dim wsSheet As Worksheet

Set wsSheet = ActiveWorkbook.Worksheets("Sheet1")

With wsSheet.OLEObjects("Combobox1").Object

.Clear

.List = wsSheet.Range("A1:A100").Value

.ListIndex = -1

End With

End Sub

Nr 92

F: Hur tar jag bort samtliga menyalternativ i arbetsbokmenyn men inte själva menyn?

S: Följande procedur tar bort samtliga menyalternativ:

Private Sub Workbook_Open()
   '© 2002 Alla rättigheter XL-Dennis
   Dim cbWorkSheet As CommandBar
   Dim i As Long, j As Long

Set cbWorkSheet = Application.CommandBars(1)

j = 30001

For i = 1 To 10

j = j + 1

If j = 30008 Then GoTo Nasta

With cbWorkSheet

.FindControl(ID:=j).Delete

End With

Nasta:

Next i

End Sub

Följande procedur återställer menyalternativen:

Private Sub Workbook_BeforeClose(Cancel As Boolean)

Dim cbWorkSheet As CommandBar

Set cbWorkSheet = Application.CommandBars(1)

cbWorkSheet.Reset

End Sub

Nr 91

F: Hur kan jag mha VBA markera samtliga blad förutom blad 1 i en arbetsbok?

S: Följande procedur visar på en möjlig lösning, där alla blad förutom blad 1 markeras:

Option Explicit

Option Base 1

Sub Skapa_Gruppredigering()

Dim BladArray() As String

Dim i As Long, j As Long

i = Worksheets.Count - 1

ReDim BladArray(i)

For j = 1 To i

BladArray(j) = Worksheets(j + 1).Name

Worksheets(BladArray).Select

Worksheets(BladArray(1)).Activate

End Sub

Nr 90

F: Hur ska jag göra för att söka igenom ett valt cellområde och få fram antal celler som innehåller "ost" respektive "bröd" i en meddelanderuta?

S: Följande procedur löser detta problem:

Option Explicit

Sub Villkorstyrd_Fargsattning()

Dim wbBok As Workbook

Dim wsBlad As Worksheet

Dim rnOmrade As Range, rnCell As Range

Dim i As Long, j As Long

Set wbBok = ActiveWorkbook

Set wsBlad = wbBok.ActiveSheet

Set rnOmrade = Selection

i = 0

j = 0

For Each rnCell In rnOmrade

If LCase(rnCell.Value) Like "*ost*" Then

rnCell.Font.ColorIndex = 5

i = i + 1

ElseIf LCase(rnCell.Value) Like "*bröd*" Then

rnCell.Font.ColorIndex = 5

j = j + 1

End If

Next rnCell

MsgBox "Antal celler med ordet ost: " & i & " st." & vbCrLf _

& "Antal celler med order bröd: " & j & " st."

End Sub

Nr 89

F: Jag har en textruta i ett formulär där datum ska anges. Hur gör jag för att tvinga användarna att ange ett korrekt datum, dvs dd-mm-åååå?

S: Följande procedur kan lösa problemet:

Private Sub cmbOK_Click()

If IsDate(Me.TextBox1) Then

Unload Me

Else

MsgBox "Du måste ange ett korrekt datum."

With Me.TextBox1

.Value = ""

.SetFocus

End With

End If

End Sub

Nr 88

F: I ett arbetsblad nyttjar jag både händelsen Private Sub Worksheet_Activate() och
Private Sub Worksheet_SelectionChange(ByVal Target As Range). När jag exekverar en annan procedur som berör arbetsbladet exekveras även dessa händelser-proceduren. Hur gör jag för att lösa detta problem?

S: Enklast är att stänga av och slå på XL:s inbyggda händelsehanterare:

With Application

.ScreenUpdating = False

.StatusBar = "Vänligen dröj - XL arbetar!"

.EnableEvents = False

End With

....kod....

With Application

.ScreenUpdating = True

.StatusBar = ""

.EnableEvents = True

End With

Nr 87

F: Jag behöver vända på all text i ett cellområde, såsom ABC till CBA.

S: Det finns två alternativ, där det ena kräver att vi skapar en funktion som används och den andra att vi markerar önskat cellområde och därefter exekverar proceduren.

Function Reverse(Varde As String) As String

Reverse = StrReverse(Varde)

End Function

Sub Reverse1()

Dim rnCell As Range

For Each rnCell In Selection

rnCell.Value = StrReverse(rnCell.Value)

Next rnCell

End Sub

Nr 86

F: Jag har skapat ett verktygsfält för en specifik arbetsbok. När flera arbetsböcker är öppna vill jag visa verktygsfältet endast när denna arbetsbok är den aktiva arbetsboken.

S: Följande händelseprocedurer skapas i "ThisWorkbook"-modulen:

Private Sub Workbook_WindowActivate(ByVal Wn As Window)

On Error Resume Next

Application.CommandBars("XL-Dennis").Visible = True

End Sub

Private Sub Workbook_WindowDeactivate(ByVal Wn As Window)

On Error Resume Next

Application.CommandBars("XL-Dennis").Visible = False

End Sub

Nr 85

F: För att underlätta för användarna vill jag att när markören befinner sig inom cellområdet C1:C10 så ska den aktuella raden inom cellområdet A:C markeras men en annan färg.

S: Följande procedur placeras i arbetsbladets modul:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Set Target = Range("C1:C10")

Cells.Interior.ColorIndex = 0

If Intersect(Target, ActiveCell) Is Nothing Then Exit Sub

Range(ActiveCell, ActiveCell.Offset(0, -2)).Interior.ColorIndex = 28

End Sub

Nr 84

F: Hur gör jag för att kopiera ett flertal arbetsblad från en arbetsbok till en befintlig arbetsbok?

S: Följande procedur löser det:

Sub Kopiera_Arbetsblad_Arbetsbok()

With Workbooks("Bok3").Worksheets

Worksheets(Array("Blad1", "Blad4")).Copy after:=.Item(.Count)

End With

End Sub

Här kopieras arbetsbladen till den öppnade befintliga arbetsboken "Bok3" efter det sista arbetsbladet.

Nr 83

F: Hur gör jag för att kopiera ett flertal arbetsblad från en arbetsbok till en ny arbetsbok?

S: Följande procedur löser det på ett effektivt sätt:

Sub Kopiera_Arbetsblad()

ThisWorkbook.Worksheets(Array("Blad1", "Blad4")).Copy

End Sub

Här skapas en ny arbetsbok med två arbetsblad, de två som kopieras. Den nya arbetsboken blir den aktiva arbetsboken.

Nr 82

F: När ett formulär öppnas vill jag att samtliga kryssrutor ska vara omarkerade - Hur gör jag det på enklaste sättet?

S: Följande procedur är en enkel lösning:

Private Sub UserForm_Initialize()

Dim cKontroll As Control

On Error Resume Next

   For Each cKontroll In Me.Controls
      If cKontroll.Name Like ("CheckBox*") Then cKontroll = False
   Next cKontroll

On Error GoTo 0

End Sub

Procedurer utgår från att alla kryssrutor börjar med ordet "CheckBox".

Nr 81

F: Hur skapar jag en mapp direkt under C:\?

S: Det sker med följande procedur:

Sub Skapa_Mapp()
MkDir "C:\XL-Dennis\"
End Sub

Nr 80

F: I ett cellområde vill jag ha det tredje textvärdet upphöjt, dvs 12³4AA

S: Enklast är att använda sig av följande procedur:

Sub Formatera_Varden()

   Dim wsBok As Workbook
   Dim wsBlad As Worksheet
   Dim rnOmrade As Range, rnCell As Range

   Set wsBok = ActiveWorkbook
   Set wsBlad = wsBok.Worksheets("Blad1")
   Set rnOmrade = wsBlad.Range("A2:A300")

For Each rnCell In rnOmrade

rnCell.Characters(3, 1).Font.Superscript = True

Next rnCell

End Sub

Nr 79

F: Hur kan jag genom kod få fram den sista använda kolumnen och den sista, var för sig?

S: Följande två procedurer visar hur dessa uppgifter kan erhållas:

Sub Sista_Kolumnen()

Dim stKolumn As String

With ActiveSheet.UsedRange.Columns

stKolumn = Replace(Left(.Item(.Count).Address(, 0), 2), "$", "")

End With

MsgBox stKolumn

End Sub

Sub Sista_Raden()

Dim stRad As String

With ActiveSheet.UsedRange.Rows

stRad = Replace(Right(.Item(.Count).Address(, 0), 2), "$", "")

End With

MsgBox stRad

End Sub

Nr 78

F: Hur skapar jag en delad arbetsbok mha VBA?

S:Följande kod skapar en delad arbetsbok:

Sub Skapad_Delad_Arbetsbok()
Dim wbAktiv As Workbook
Set wbAktiv = ActiveWorkbook

   Application.DisplayAlerts = False
   wbAktiv.ProtectSharing
   Application.DisplayAlerts = True
End Sub

Medan följande kod återställer arbetsboken:

Sub Skapa_Odelad_Arbetsbok()
Dim wbAktiv As Workbook
Set wbAktiv = ActiveWorkbook

Application.DisplayAlerts = False

   wbAktiv.UnprotectSharing
   If wbAktiv.MultiUserEditing Then
      wbAktiv.ExclusiveAccess
   End If

Application.DisplayAlerts = True

End Sub

Nr 77

F: Jag hämtar extern data, via MS Query, till de första 100 raderna. Ibland fylls inte alla rader varför jag vill dölja de tomma raderna i intervallet.

S: Följande procedur löser problemet:

Sub Dolj_Rader()

   Dim wsBlad As Worksheet
   Dim rnOmrade As Range, rnVarde As Range

   Set wsBlad = ThisWorkbook.Worksheets("Blad1")
   Set rnOmrade = wsBlad.Range("A1:A100")

rnOmrade.EntireRow.Hidden = False

With rnOmrade

Set rnVarde = .Find(What:="")

Range(rnVarde, Range("A100")).EntireRow.Hidden = True

End With

End Sub

Nr 76

F: Jag vill ange utskriftsområdet till ett namngivet cellområde i det aktiva arbetsbladet - Hur göra?

S: Enklast är mha följande kod:

ActiveSheet.PageSetup.PrintArea = ActiveSheet.Range("XLDennis").Address

Nr 75

F: Hur gör jag för att visa den inbyggda dialogrutan för att öppna arbetsböcker och då med mappen "c:\Arbete" som standardmapp?

S: Jo, det går att göra med följande kodrad:

Application.Dialogs(xlDialogOpen).Show ("c:\Arbete")

Nr 74

F: Hur kan jag ta bort de automatiska horisontella sidbrytningar i det aktiva arbetsbladet?

S: Så här:

Sub Ta_Bort_Horisontella_Sidbrytningar()
Dim hpBrytning As HPageBreak

For Each hpBrytning In ActiveSheet
hpBrytning.Delete
Next hpBrytning

End Sub

Nr 73

F: Hur söker jag celler med t ex värdet 1 i en kolumn och ersätta värdet med t ex 10?

S: Följande exempel visar hur det kan ske:

Sub Sok_Hitta()
Dim rnOmrade As Range, rnCell As Range
Dim stAdress As String

Set rnOmrade = _
ActiveWorkbook.Worksheets("Blad1").Range(Range("A1"), _

Programmering Frågor & Svar 1 - 100

Programmering
Frågor & Svar 1 - 100