On this website you will find some typical examples from my VBA-tanker.
Example 1: How to consolidate sales per month and costcenter
Sub FillData()
Dim VarDat As Variant
Dim VarTotal As Variant
Dim lngRow As Long
Dim lngRowMax As Long
Dim lngZ As Long
Dim lngCol As Long
Application.Calculation = xlCalculationManual
lngRowMax = tbl_Data.UsedRange.Rows.Count
VarDat = tbl_Data.Range("A2:D" & lngRowMax)
With tbl_Matrix
.Range("Matrix").ClearContents
VarTotal = .Range("A1:M41")
For lngRow = 1 To UBound(VarDat, 1)
For lngZ = 1 To UBound(VarTotal, 1)
lngCol = VarDat(lngRow, 3) + 1
If VarTotal(lngZ, 1) = VarDat(lngRow, 1) Then
VarTotal(lngZ, lngCol) = VarTotal(lngZ, lngCol) + VarDat(lngRow, 4)
Exit For
End If
Next lngZ
Next lngRow
.Range(.Cells(1, 1), .Cells(UBound(VarTotal, 1), UBound(VarTotal, 2))) = VarTotal
End With
Application.Calculation = xlCalculationAutomatic
End Sub
'VBA-Tanker: ID 1048
Buy the VBA tanker now to get 1 year free Updates!
Example 2: How to consolidate sales per month
Sub ConsolidateSalesPerMonth()
Dim cn As Object
Dim rs As Object
Dim strConnection As String
Dim strSQL As String
Dim wkbTarget As Workbook
Dim intZ As Integer
Dim i As Integer
Set cn = CreateObject("ADODB.CONNECTION")
strConnection = _
"DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)}; DBQ=" & _
ThisWorkbook.FullName
With cn
.Open strConnection
intZ = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 12
Set wkbTarget = Workbooks.Add
Application.SheetsInNewWorkbook = intZ
For i = 1 To 12
wkbTarget.Worksheets(i).Columns(1).NumberFormat = "DD.MM.YYYY"
strSQL = tbl_month.TextBoxes(1).Text & i
Set rs = CreateObject("ADODB.RECORDSET")
With rs
.Source = strSQL
.ActiveConnection = strConnection
.Open
wkbTarget.Worksheets(i).Range("A1").CopyFromRecordset rs
wkbTarget.Worksheets(i).Range("D1").Value = _
Application.WorksheetFunction.Sum(wkbTarget.Worksheets(i).Columns(2))
.Close
End With
Next i
End With
cn.Close
Set cn = Nothing
Set rs = Nothing
End Sub
'VBA-Tanker: ID 1043
Buy the VBA tanker now to get free e-mail hotline!
Example 3: How to program a progressBar with percentage of rest runtime of macro
Private Sub UserForm_Activate()
Dim lngRowMax As Long
Dim lngRow As Long
Dim lngProg As Long
Dim dblFakt As Double
10 On Error GoTo UserForm_Activate_Error
20 Application.Calculation = xlCalculationManual
30 With Sheet1
40 lngRowMax = .UsedRange.Rows.Count
50 lngproz = 200
60 dblFakt = lngRowMax / lngproz
70 Me.ProgressBar1.Max = lngRowMax
80 For lngRow = 2 To lngRowMax
90 If .Range("A" & lngRow).Value >= 80 Then
100 .Range("A" & lngRow).Interior.ColorIndex = 4
110 .Range("B" & lngRow).Value = .Range("A" & lngRow).Value * 1.1
120 End If
130 If lngRow Mod 10000 = 0 Then
140 Me.Label1.Caption = Format(lngRow / lngRowMax, "0.00 %")
150 Me.Label3.Caption = "row " & lngRow & " / " & lngRowMax
160 DoEvents
165
170 End If
180 Me.ProgressBar1.Value = lngRow
190 Next lngRow
200 End With
210 Application.Calculation = xlCalculationAutomatic
220 Unload Me
230 On Error GoTo 0
240 Exit Sub
UserForm_Activate_Error:
250 MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure UserForm_Activate of Formular UserForm1_" & Erl
260 Application.Calculation = xlCalculationAutomatic
End Sub
'VBA-Tanker, ID 1029
Buy the VBA tanker now to learn new techniques!
Example 4: How to insert a PDF as object in a sheet
Sub InsertPDFasIcon()
Dim objFileDialog As Office.FileDialog
Dim VarFile As Variant
Set objFileDialog = Application.FileDialog(MsoFileDialogType.msoFileDialogFilePicker)
With objFileDialog
.ButtonName = "Insert PDF"
.Title = "Link to pdf"
.InitialView = msoFileDialogViewList
.Show
If .SelectedItems.Count = 1 Then
VarFile = (.SelectedItems(1))
With Tabelle1
.OLEObjects.Add Filename:=VarFile, Link:=False, DisplayAsIcon:=False, _
Left:=40, Top:=40, Width:=150, Height:=10
End With
End If
End With
End Sub
'VBA-Tanker, ID 1022
Buy the VBA tanker now to benefit from 25 years of vba experience!
Example 5: How to find formatted value in a Column
Sub FindValueandFormat()
Dim rngHit As Range
With Sheet1
Application.FindFormat.Font.Bold = True
Set rngHit = .Range("B:B").Find(what:=.Range("F1").Value, lookat:=xlWhole, _
SearchFormat:=true)
If Not rngHit Is Nothing Then
.Range("G1").Value = rngHit.Offset(0, -1).Value
Else
.Range("G1").ClearContents
End If
Application.FindFormat.Clear
End With
End Sub
'VBA-Tanker, ID 1005