Visual Basic

1. Första manuset

Duktiga utvecklare fnyser åt detta tips men nybörjare börjar enklast med att spela in ett makro (se Windows/Office). Ett inspelat Visual Basic-manus som skriver lite text i en cell kan se ut så här:

Sub Makro1()
'
' Makro1 Makro
' Makrot inspelat 2009-05-10 av Nicholas Hjelmberg
'
Range("A1").Select
ActiveCell.FormulaR1C1 = "Text i cell A1"
End Sub

"Sub" anger början på manuset och "End Sub" anger slutet. Rader som börjar med apostrof är kommentarer och alltså inte en del av koden. Det hör till god utvecklarsed att kommentera sin kod så att andra lättare förstår den. Själva koden består av två rader, en rad som väljer cell A1 och en rad som skriver text i cellen.

2. Spara Excelfil som textfil

Om du behöver spara en Excelfil som textfil, till exempel för att importera siffror till ett annat program, kan du använda följande enkla manus. Det sparar innehållet i "Blad1" som en textfil med namnet "textfil.txt" i mappen "c:\mapp.

Sub Textfil()

Sheets("Blad1").Copy
ChDir "c:\mapp"
ActiveWorkbook.SaveAs Filename:= _
"c:\mapp\textfil.txt", FileFormat:=xlText, _
CreateBackup:=False
ActiveWorkbook.Save
ActiveWindow.Close

End Sub

Nedanstående mer komplicerade manus sparar en citationsteckenseparerad textfil. Jag använde det för att skapa importfiler till affärssystemet Visma. I manuset finns flera finesser:

• Variabler: "Behållare" som kan lagra värden för senare användning i manuset.
• Loopar: Nyckelordet "For" [villkor] [kod] följt av "Next" som upprepar koden så länge villkoret uppfylls.
• Villkor: Konstruktionen "If [villkor] Then [kod 1] Else [kod 2] som utför kod 1 om villkoret uppfylls, annars kod 2.

Sub Utfil()

' Variabler
Dim DestFile As String
Dim FileNum As Integer
Dim ColumnCount As Integer
Dim RowCount As Integer

' Frågar efter filnamn
DestFile = InputBox("Ange filnamn med komplett sökväg" _
& Chr(10) & "(t ex c:\textfil.txt):", "Quote-Comma Exporter")

' Hämtar nästa filhanterare
FileNum = FreeFile()

' Öppnar destinationsfil
Open DestFile For Output As #FileNum

' Anger första raden i filen (importparametrar till Visma)
' WaVo = Verifikationstabell
' BndNo etc. = Buntnr, vernr, verdatum, debet, kredit, kst, belopp
Print #FileNum, "@WaVo (BndNo, VoNo, VoDt, DbAcNo, CrAcNo, R2, Am)"

' Loop för varje rad i markerade celler
For RowCount = 1 To Selection.Rows.Count

' Loop för varje kolumn i markerade celler
For ColumnCount = 1 To Selection.Columns.Count

' Skriver in cellinnehåll inom citationstecken
Print #FileNum, """" & Selection.Cells(RowCount, _
ColumnCount).Text & """";

' Kontrollerar om sista kolumn
If ColumnCount = Selection.Columns.Count Then
' Om sista kolumn så ny rad
Print #FileNum,
Else
' Om inte sista kolumn så mellanslag.
Print #FileNum, " ";
End If
' Startar nästa kolumnloop
Next ColumnCount
' Startar nästa radloop.
Next RowCount

' Stänger textfil
Close #FileNum

EndSub

3. Läs in textfil till Excelfil

Nedanstående manus gör tvärtom och läser in textiler till Excel. Jag använde det för att läsa in exportfiler från affärssystemet Visma. I manuset finns följande finesser:

• Felhanterare: Vid fel ("On Error") hoppar manuset till en felhanteringskod ("ErrorHandler") längre ned. Det här manuset ger ett felmeddelande ("MsgBox") och avslutar ("Exit Sub"). Ett alternativ är koden "Resume Next" som återupptar manuset.
• Cellmarkering: Nyckelorden "Range" och "Selection" kan användas tillsammans för att markera och bearbeta celler
  • Range("A1").Select: Markera cell A1
  • Selection.EntireRow.Delete: Markera hela raden och radera den
  • Selection.End(xlDown).Select: Gå till den sist ifyllda cellen i kolumnen
  • Range(Selection, Selection.End(xlDown)).Select: Markera alla ifyllda celler i kolumnen
  • Gå till intilliggande celler: Medan nyckelordet "Range" arbetar med absoluta cellvärden så arbetar nyckelordet "ActiveCell.Offset(x, y)" med relativa cellvärden. x anger hur många rader åt höger markören ska gå och y hur många rader nedåt. Om du till exempel står i cell A1 så anger ActiveCell.Offset(1, 2) att du ska arbeta i cell B3.

  Sub (Infil)
  '
  Dim CountRows As String
  Dim FileName As String
  '
  FileName = InputBox("Ange filnamn med komplett sökväg" _
  & Chr(10) & "(t ex c:\textfil.txt):")
  
  On Error GoTo ErrorHandler
  'Läs in de första tio tecknen i första fältet o s v
  Workbooks.OpenText FileName _
  , Origin:=xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:= _
  Array(Array(0, 2), Array(9, 2), Array(19, 2), Array(29, 2))
  On Error GoTo 0
  
  'Ta bort första raden
  Range("A1").Select
  If ActiveCell.Value = "#H" Then
  Selection.EntireRow.Delete
  End If
  
  'Ta bort sista raden
  Selection.End(xlDown).Select
  If ActiveCell.Value = "#T" Then
  Selection.EntireRow.Delete
  End If
  
  'Räkna rader
  Range("A1").Select
  Range(Selection, Selection.End(xlDown)).Select
  CountRows = Selection.Rows.Count
  
  'Sätt in rubrikrad högst upp och sätt till fet stil
  Rows("1:1").Select
  Selection.EntireRow.Insert
  Selection.Font.Bold = True
  
  'Sätt in rubriker
  Range("A1").Select
  ActiveCell.FormulaR1C1 = "Konto"
  Range("B1").Select
  ActiveCell.FormulaR1C1 = "Debet"
  Range("C1").Select
  ActiveCell.FormulaR1C1 = "Kredit"
  Range("D1").Select
  ActiveCell.Value = 1 / 100
  
  'Sätt beloppsformat
  Columns("B:C").Select
  Selection.NumberFormat = "#,##0.00"
  
  'Dividera beloppen med 100 (de importerades med ören men utan kommatecken)
  Range("D1").Select
  Selection.Copy
  Range("B1:C1").Select
  Range(Selection, Selection.End(xlDown)).Select
  Selection.PasteSpecial Paste:=xlValues, Operation:=xlMultiply, SkipBlanks _
  :=False, Transpose:=False
  
  'Sätt in skiljelinje och summarad längst ned och sätt till fet stil
  Range("B1").Select
  Selection.End(xlDown).Select
  With Selection.Borders(xlEdgeBottom)
  .LineStyle = xlContinuous
  .Weight = xlThin
  .ColorIndex = xlAutomatic
  End With
  ActiveCell.Offset(1, 0).FormulaR1C1 = "=SUM(R[-" & CountRows & "]C:R[-1]C)"
  ActiveCell.Offset(1, 0).Font.Bold = True
  Range("C1").Select
  Selection.End(xlDown).Select
  With Selection.Borders(xlEdgeBottom)
  .LineStyle = xlContinuous
  .Weight = xlThin
  .ColorIndex = xlAutomatic
  End With
  ActiveCell.Offset(1, 0).FormulaR1C1 = "=SUM(R[-" & CountRows & "]C:R[-1]C)"
  ActiveCell.Offset(1, 0).Font.Bold = True
  
  'Anpassa kolumnbredd och frys fönster
  Cells.Select
  Cells.EntireColumn.AutoFit
  Range("A2").Select
  ActiveWindow.FreezePanes = True
  Exit Sub
  
  ErrorHandler:
  MsgBox ("File not found")
  Exit Sub
  
  End Sub

4. Hämta data från Excelfil

Följande manus använde jag för att hämta data (timmar och fakturerade belopp) från en totallista i en Excelfil till en detaljtabell i en annan.

Sub Hamta_Data()
'Variabler för att hämta rätt projekt, företag och år
Dim Project As String
Dim Workbook As String
Dim T As String
Dim F As String
Dim Company As String

Project = Range("B7")
Workbook = ActiveWorkbook.Name
Year = Worksheet(Range("A1"))
Company = Range("H5")
T = "T" & Year
F = "F" & Year

'Lås upp arket med lösenordet "excel" för att kunna göra förändringar
Sheets(Year).Unprotect ("excel")
Range("A38").Select
Range(Selection, Selection.End(xlDown)).ClearContents
On Error GoTo ErrorHandler0

'Gå till totallistan och fliken för det aktuella företaget och året
'Uppdatera och kopiera pivottabelldata för det aktuella projektet
Workbooks.Open ActiveWorkbook.Path & "\..\Total_" & Company & ".xls", , False, , "excel", , True
On Error GoTo ErrorHandler1
Sheets(F).Select
ActiveSheet.PivotTables("F").PivotCache.Refresh
Continue1:
On Error GoTo ErrorHandler2
Sheets(T).Select
ActiveSheet.PivotTables("T").PivotCache.Refresh
On Error GoTo ErrorHandler3
ActiveSheet.PivotTables("T").PivotSelect Project, xlDataAndLabel, True
ActiveCell.Offset(0, 1).Select
Range(Selection, Selection.End(xlDown)).Copy
Continue2:
On Error GoTo 0

'Klistra in pivottabelldata för det aktuella projektet
Windows(Workbook).Activate
Sheets(Year).Select
Range("A38").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Windows("Total_" & Company & ".xls").Activate
ActiveWorkbook.Save
ActiveWindow.Close
Application.Run "Protect"
Exit Sub

Felhantering om fil eller data ej kan hittas
ErrorHandler0:
MsgBox ("Datafilen kunde ej hittas. Kontakta systemadministratören.")
Exit Sub

ErrorHandler1:
Windows(Workbook).Activate
MsgBox ("Faktureringsdata kunde ej uppdateras. Kontakta systemadministratören.")
Windows("Total_" & Company & ".xls").Activate
Resume Next
GoTo Continue1

ErrorHandler2:
Windows(Workbook).Activate
MsgBox ("Tidsdata kunde ej uppdateras. Kontakta systemadministratören.")
Windows("Total_" & Company & ".xls").Activate
Resume Next
GoTo Continue2

ErrorHandler3:
Workbooks("Total_" & Company & ".xls").Save
Workbooks("Total_" & Company & ".xls").Close
Windows(Workbook).Activate
Sheets(Year).Select
MsgBox ("Det finns ingen rapporterad tid på projektet.")
Application.Run "Protect"
Exit Sub

End Sub

5. Hämta data från databas

Affärssystem i all ära men ofta måste man hämta in data i Excel för att arbeta med den. Databasfrågor kan du skapa med ODBC-kopplingar och Microsoft Query (se Windows Vista och Office 2007). Med Visual Basic kan du sedan automatiskt uppdatera den med följande manus:

Sub Data()
Sheets("Data").Select
Application.Goto Reference:="Databasfråga"
Selection.QueryTable.Refresh BackgroundQuery:=False

För mer flexibel datahämtning kan du lägga in hela databasfrågan i manuset enligt följande:

Sub Data()

Dim qtData As QueryTable
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim rnStart As Range

'Gå till datafliken och rensa gammal data
Sheets("Data").Select
Range("A:E").Select
Selection.ClearContents

'Ange databas och SQL-sats
Const stCon As String = "ODBC;DSN=visma1;UID=sa;PWD="
Const stSQL As String = _
"SELECT AcTr.AcNo AS Konto, AcTr.AcAm AS Belopp, AcTr.R1 AS Projekt, " & _
"AcTr.AcYr*100+AcTr.AcPr AS Period, AcTr.VoNo AS Ver " & _
"FROM F0001.dbo.AcTr AcTr " & _
"WHERE AcTr.R1 > 0 "

'Hämta data enligt databas och SQL-sats ovan
Set wbBook = ActiveWorkbook
Set wsSheet = wbBook.Worksheets("Data")
Set rnStart = Range("A1")
With wsSheet
Set rnStart = .Range("A1")
End With
Set qtData = wsSheet.QueryTables.Add( _
Connection:=stCon, _
Destination:=rnStart, _
Sql:=stSQL)

'Bibehåll formatering och kopiera angränsande formler till alla rader
With qtData
.FillAdjacentFormulas = True
.PreserveFormatting = True
.Refresh
End With

End Sub

6. Sök data till rapporter

Excel har egentligen utmärkta verktyg för att skapa rapporter, såsom summaformler och pivottabeller (se Excel). Fördelen med Visual Basic är att du kan använda loopar och urvalskriterier för att skapa mer anpassade rapporter. Nedanstående manus använde jag för att skapa en rapport per projekt, förutsatt att det fanns belopp bokade på det. Datan hämtade jag med databasfrågan ovan.

En finess i det här manuset är arrays, som kan beskrivas som variabler med flera "behållare". Jag använder en array för att lista alla projekt och sedan loopa igenom dem en efter en.

Sub Rapport()

'Variabler, projektfran och projekttill anger önskat projektintervall
Dim Projektfran As Integer
Dim Projekttill As Integer
Projektfran = Range("B2").Value
Projekttill = Range("C2").Value
Dim Projektarray As Variant
Dim Projekt As Integer

'Rensa gamla rapporter
Sheets("Rapport").Select
Cells.Select
Selection.Clear
Sheets("Start").Select

'Skapa projektrapporter
'Börja med att gå till AA-kolumnen, där alla projekt finns
'Hämta sedan alla projekt i det önskade projektintervallet till din array
Projektcell = "AA" & Projektfran - 1 & ":" & "AA" & Projekttill
Projektarray = Range(Projektcell).Value

'Loopa igenom alla projekt i din array
'För varje projekt, uppdatera cell B2 (som uppdaterar rapporten),
'kontrollera att cell B3 (som innehåller en kontrollsiffra) är 1 och
'kopiera rapporten i cell B4:D10 till fliken "Total"
For i = 1 To UBound(Projektarray)
Range("B2").Select
ActiveCell.FormulaR1C1 = Projektarray(i, 1)
If Range("B3").Value = 1 Then
Range("B4:D13").Select
Selection.Copy
Sheets("Total").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.FormulaR1C1 = "Projekt " & Projektarray(i, 1)
ActiveCell.Offset(10, 0).Select
Sheets("Data").Select
End If
Next

'Avsluta med att gå överst i varje flik och gå ur kopieringsläget
Sheets("Total").Select
Range("A1").Select
Sheets("Start").Select
Range("A1").Select
Application.CutCopyMode = False
End Sub

7. Navigera i Excelark

Excelark har en tendens att bli väldigt stora men med följande lilla manus kan du navigera med hjälp av dialogrutor.

Sub Blad()

' Variabler
Dim Blad As String

' Frågar efter blad
Blad = InputBox("Ange vilket blad du vill gå till.")

' Om Avbryt så avsluta manus
If StrPtr(Blad) = 0 Then End

' Om blad inte finns så felmeddelande
On Error GoTo Fel

' Gå till blad
Sheets(Blad).Select

' Stäng av felmeddelande
On Error GoTo 0
Exit Sub

' Meddelande om blad inte finns
Fel: MsgBox ("Blad " & Blad & " saknas.")

End Sub

8. Rätta till fel format i celler

Det är lätt att klippa och klistra cellvärden i Excel men får cellerna fel format, vilket kan ge problem om de ska användas i funktioner. Här är några kodsträngar som jag ibland använder för att rätta till felen:

Cellvärden får textformat istället för nummerformat

Markera cellerna, ändra format till nummer och kör följande kod. Den gör samma sak om du klickar i varje cell och trycker returtangenten, vilket uppdaterar formatet.

For Each xCell In Selection
xCell.Value = xCell.Value
Next xCell

Cellvärden är inte tomma trots att de ser tomma ut.

Markera cellerna och kör följade kod. Den gör samma sak om du klickar i varje cell och trycker delete-tangenten.

Cells.Select
Selection.SpecialCells(xlCellTypeConstants, 23).Select
For Each cell In Selection
If cell = "" Then
cell.Value = Empty
End If
Next

9. Loopa genom fillista

I mitt förra jobb var Excel ett viktigt rapporteringsverktyg och jag behövde ofta arbeta med stora uppsättningar av Excelark. Att då arbeta med ett Excelark i taget är ganska tidsödande så varför inte låta ett makro göra jobbet? Nedanstående makro utgår från en fil där sökvägarna till de olika filerna listas i A-kolumnen. Makrot går igenom sökvägarna en efter en, öppnar varje fil, utför den åtgärd man anger, sparar och stänger. Det här exemplet skriver texten "Valfri text" i cell A1 men man kan naturligtvis spela in ett mer kompliceat makro och klistra in det i stället. Tänk bara på att säkerhetsspara och testa makrot på ett par filer först så att det verkligen gör vad du tänkt dig.

Dim Cell As Variant
Range("A1").Select
Cell = Range(Selection, Selection.End(xlDown)).Value
For i = 1 To UBound(Cell)
Workbooks.Open(Cell(i, 1))
'Börja åtgärd här
Range("A1").Select
ActiveCell.FormulaR1C1 = "Valfri text"
'Sluta åtgärd här
Workbooks.Close(SaveChanges:=True)
Next

10. Hämta data i två steg

Excel har gott om funktioner för att hitta data enligt ett villkor men hur gör man om det hittade datat i sin tur behöver hitta data? En sådan fråga ställdes jag inför när en kollega behövde koppla ihop butiker och artiklar via butikens artikelgrupp. Det här makrot går igenom butiker i A-kolumnen, använder butikens butiksgrupp till att hämta alla artiklar i butiksgruppen och skriver en lista med butik i första kolumnen och artikel i andra kolumnen.

Sub Artikel()
Dim Cell As Variant
Dim Butik As String
Dim Butiksgrupp1 As String
Dim Butiksgrupp2 As String
Dim Rad1 As Long
Dim Rad2 As Long
Dim ButikCount As Integer 'Börja med att gå till A-kolumnen, där alla butiker finns 'Hämta sedan alla artiklar i det önskade artikelintervallet till din array
Range("A2").Select
Cell = Range(Selection, Selection.End(xlDown)).Value
'Loopa genom alla butiker i butikslistan i A-kolumnen
For i = 1 To UBound(Cell)
ButikCount = ActiveCell.Row
Butik = ActiveCell.Value
'Hämta butikens butiksgrupp i B-kolumnen och spara butikens radnummer
ActiveCell.Offset(0, 1).Select
Butiksgrupp1 = ActiveCell.Value
'Sök upp butiksgruppen i artikellistan i D-kolumnen
Rad1 = Application.WorksheetFunction.Match(Butiksgrupp1, Range("D:D"), 0)
Butiksgrupp2 = Butiksgrupp1
Range("D" & Rad1).Select

'Markera alla rader med butiksgruppen
Do While Butiksgrupp1 = Butiksgrupp2
ActiveCell.Offset(1, 0).Select
Butiksgrupp2 = ActiveCell.Value
Loop

'Kopiera butiksgruppens artiklar i E-kolumnen
ActiveCell.Offset(-1, 0).Select
Rad2 = ActiveCell.Row
Range("E" & Rad1 & ":E" & Rad2).Select
Selection.Copy
Range("I1").Select

'Gå till nästa tomma rad i I-kolumnen (eller första raden om alla rader är tomma)
'Klistra in artiklarna i I-kolumnen
If IsEmpty(ActiveCell.Offset(1, 0)) Then
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.End(xlDown).Offset(1, 0).Select
End If

ActiveSheet.Paste

'Kopiera butiksnumret och klistra in det i H-kolumnen för varje artikelrad
Range("A" & ButikCount).Select
Selection.Copy
Range("H1").Select

If IsEmpty(ActiveCell.Offset(1, 0)) Then
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.End(xlDown).Offset(1, 0).Select
End If

Range("H" & ActiveCell.Row & ":H" & ActiveCell.Row + Rad2 - Rad1).Select
ActiveSheet.Paste

Range("A" & ButikCount + 1).Select
Application.CutCopyMode = False
Next
End Sub

11. Hämta data i två steg

Det är inte alltid den data man behöver finns i en och samma fil. Det här enkla makrot går igenom alla Excelfiler i en angiven mapp och kopierar och klistrar in alla rader och kolumner efter varandra. Det förutsätter att man i cell B1 angivit sökvägen till mappen, t ex C:\Filer\ på en PC. Varje fil antas ha en första rubrikrad, varför makrot börjar kopiera från cell A2. Range(Selection, Selection.End(xlDown).End(xlToRight)).Select används för att kopiera alla rader och kolumner med data nedanför och till höger om denna cell.

Sub Konsolidera()
Dim fileName As Variant
Dim fileDir As String

Worksheets("Inställningar").Activate
fileDir = Cells(1, "B").Value
fileName = Dir(fileDir)
Worksheets("Data").Activate

While fileName <> ""

Workbooks.Open (fileDir & fileName)
'Börja åtgärd här
Range("A2").Select
Range(Selection, Selection.End(xlDown).End(xlToRight)).Select
Selection.Copy

Windows("Konsolidera.xlsm").Activate

Range("A2").Select
If IsEmpty(ActiveCell) Then
ActiveSheet.Paste
Else
ActiveCell.End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
End If

'Sluta åtgärd här

Windows(fileName).Activate
Windows(fileName).Close

'ActiveWorkbook.Close True

'Set the fileName to the next file
fileName = Dir

Wend

Range("A1").Select
End Sub