Multiple Condition/criteria sum function for excel

Forrás: http://www.ozgrid.com/VBA/sum-multi-criteria.htm

Function SumByCriteria(Sum_Range As Range, Criteria1, Criteria1Range As Range, _
Criteria2, Criteria2Range As Range, Optional Criteria3, _
Optional Criteria3Range As Range, Optional Criteria4, _
Optional Criteria4Range As Range, Optional Criteria5, _
Optional Criteria5Range As Range) As Long

Dim lLoopStop As Long, lLoop As Long, rRange As Range, lRow As Long
Dim sTotal As Single, bVal1 As Boolean, bVal2 As Boolean, bVal3 As Boolean
Dim bVal4 As Boolean, bVal5 As Boolean, bVal1b As Boolean, bVal2b As Boolean, bVal3b As Boolean
Dim bVal4b As Boolean, bVal5b As Boolean, lCriteriaUsed As Long

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''Written by ozgrid.com''''''''''''''''''''''''''''''''''''''
'Sums Values in Sum_Range when up to 5 conditions are met in corresponding cells.
'All ranges used should as small as possible for efficieny
''IF YOU HAVE 2007 USE SUMIFS
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


lLoopStop = WorksheetFunction.CountIf(Criteria1Range, Criteria1)

bVal3 = Not Criteria3Range Is Nothing
bVal4 = Not Criteria4Range Is Nothing
bVal5 = Not Criteria5Range Is Nothing

If bVal5 = False Then lCriteriaUsed = 4
If bVal4 = False Then lCriteriaUsed = 3
If bVal3 = False Then lCriteriaUsed = 2

Set rRange = Criteria1Range(1, 1)
For lLoop = 1 To lLoopStop

Set rRange = Criteria1Range.Find(Criteria1, rRange, _
xlFormulas, xlWhole, xlByRows, xlNext, False)

lRow = rRange.Row

If bVal5 = True Then bVal5b = Criteria5Range(lRow, 1) = Criteria5
If bVal4 = True Then bVal4b = Criteria4Range(lRow, 1) = Criteria4
If bVal3 = True Then bVal3b = Criteria3Range(lRow, 1) = Criteria3
bVal2b = Criteria2Range(lRow, 1) = Criteria2
bVal1b = Criteria1Range(lRow, 1) = Criteria1

If lCriteriaUsed > 4 Then
If bVal5b And bVal4b And bVal3b And bVal2 And bVal1b Then
sTotal = WorksheetFunction.Sum(Sum_Range(lRow, 1), sTotal)
End If
ElseIf lCriteriaUsed > 3 Then
If bVal4b And bVal3b And bVal2b And bVal1b Then
sTotal = WorksheetFunction.Sum(Sum_Range(lRow, 1), sTotal)
End If
ElseIf lCriteriaUsed > 2 Then
If bVal3b And bVal2 And bVal1b Then
sTotal = WorksheetFunction.Sum(Sum_Range(lRow, 1), sTotal)
End If
ElseIf bVal2b And bVal1b Then
sTotal = WorksheetFunction.Sum(Sum_Range(lRow, 1), sTotal)
End If

Next lLoop
SumByCriteria = sTotal
End Function

Example usage;

=SumByCriteria(A1:A21,"cat",C1:C21,"furry",E1:E21,"fluffy",G1:G21,"persian",I1:I21)

Excel: dupla kattintás letiltása

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.EditDirectlyInCell = True
Range("A1").Activate
Cancel = True 'Cancel the default behaviour
End Sub

Forrás:
http://www.thecodecage.com/forumz/excel-vba-programming/91029-disable-cursor-when-double-click.html

Excel: hang lejátszása adott feltétel teljesülésekor

The Alarm function

Copy the code below to a VBA module in your workbook.
'Windows API function declaration
Private Declare Function PlaySound Lib "winmm.dll" _
Alias "PlaySoundA" (ByVal lpszName As String, _
ByVal hModule As Long, ByVal dwFlags As Long) As Long

Function Alarm(Cell, Condition)
Dim WAVFile As String
Const SND_ASYNC = &H1
Const SND_FILENAME = &H20000
On Error GoTo ErrHandler
If Evaluate(Cell.Value & Condition) Then
WAVFile = ThisWorkbook.Path & "\sound.wav" 'Edit this statement
Call PlaySound(WAVFile, 0&, SND_ASYNC Or SND_FILENAME)
Alarm = True
Exit Function
End If
ErrHandler:
Alarm = False
End Function


Following are examples of formulas that use this function:
=Alarm(A1,">=1000")

Forrás: Spreadsheetpage.com

Utolsó nem üres cella sorszáma, értéke

The LASTINCOLUMN function

Function LASTINCOLUMN(rngInput As Range)
Dim WorkRange As Range
Dim i As Long, CellCount As Long
Application.Volatile
Set WorkRange = rngInput.Columns(1).EntireColumn
Set WorkRange = Intersect(WorkRange.Parent.UsedRange, WorkRange)
CellCount = WorkRange.Count
For i = CellCount To 1 Step -1
If Not IsEmpty(WorkRange(i)) Then
LASTINCOLUMN = WorkRange(i).Value
Exit Function
End If
Next i
End Function

Utolsó érték sorszáma esetén: LASTINCOLUMN = WorkRange(i).row

The LASTINROW function

Function LASTINROW(rngInput As Range) As Variant
Dim WorkRange As Range
Dim i As Long, CellCount As Long
Application.Volatile
Set WorkRange = rngInput.Rows(1).EntireRow
Set WorkRange = Intersect(WorkRange.Parent.UsedRange, WorkRange)
CellCount = WorkRange.Count
For i = CellCount To 1 Step -1
If Not IsEmpty(WorkRange(i)) Then
LASTINROW = WorkRange(i).Value
Exit Function
End If
Next i
End Function

Forrás: Spreadsheetpage.com

VBE ablak helyreállítása

Restore the VBE windows to their default positions using VBA in Microsoft Excel

1. Close Excel and the VBE.
2. Run RegEdit.
3. Navigate to HKEY_USERS\.Default\Software\Microsoft\VBA\Office.
4. Rename (or delete) the value Dock (e.g. ;Dock), Excel will recreate it when it starts next time.
5. Close RegEdit.
6. Open Excel and VBE, the windows are now at their default positions.

Forrás: exceltip.com

Excel Konvertálás UTF-8 -ra

Private Function UTF8_Encode(ByVal sStr As String)
' Kiegészítés Excel-hez, hogy tudjon UTF-8 kódlapra konvertálni
For l& = 1 To Len(sStr)
lChar& = AscW(Mid(sStr, l&, 1))
If lChar& < 128 Then
sUtf8$ = sUtf8$ + Mid(sStr, l&, 1)
ElseIf ((lChar& > 127) And (lChar& < 2048)) Then
sUtf8$ = sUtf8$ + Chr(((lChar& \ 64) Or 192))
sUtf8$ = sUtf8$ + Chr(((lChar& And 63) Or 128))
Else
sUtf8$ = sUtf8$ + Chr(((lChar& \ 144) Or 234))
sUtf8$ = sUtf8$ + Chr((((lChar& \ 64) And 63) Or 128))
sUtf8$ = sUtf8$ + Chr(((lChar& And 63) Or 128))
End If
Next l&

UTF8_Encode = sUtf8$
End Function

Forrás:
http://prog.hu/tudastar/91087/Excel+vba+utf8+export+bom+nelkul.html

Excel: Könyvtár létezése függvény

' Check if a directory exists

Public Function CheckDir(Directory As String) As Boolean
On Error GoTo ErrNotExist
ChDir (Directory)
CheckDir = True
Exit Function
ErrNotExist:
CheckDir = False
End Function

Forrás: http://www.asap-utilities.com/excel-tips-detail.php?categorie=9&m=97

Status bar információ

Sub CountDown()

  Dim intCounter As Integer
  Dim bln As Boolean
  bln = Application.DisplayStatusBar
  Application.DisplayStatusBar = True
  For intCounter = 30 To 1 Step -1
  Application.StatusBar = intCounter & " Seconds..."
  Application.Wait Now + TimeSerial(0, 0, 1)
  Next intCounter
  Application.StatusBar = False
  Application.DisplayStatusBar = bln

End Sub

' Forrás: http://www.exceltip.com/show_tip/Menus,_Toolbars,_Status_bar_in_VBA/Countdown_in_status_bar_using_VBA_in_Microsoft_Excel/347.html

Csatolt fájlokról lista Excelben

Sub Csatolt_fajlok()
' Csatolt fájlokról készít egy kimutatást
kjaktiv = ActiveWorkbook.Name
' megjeleníti a csatolt Excel fájlokat
aLinks = ActiveWorkbook.LinkSources(xlLinkTypeExcelLinks)
If Not IsEmpty(aLinks) Then
' For i = 1 To UBound(aLinks)
  'MsgBox "Link " & i & ": " & aLinks(i)
  ' Next i
  Windows("csatolt.xls").Activate
  Sheets("csatolás").Select
  kjdb = Worksheets("csatolás").Range("d1")
'Set NewSheet = Worksheets.Add
  For i = 1 To UBound(aLinks)
  Worksheets("csatolás").Cells(kjdb + i + 1, 1).Value = kjaktiv
  Worksheets("csatolás").Cells(kjdb + i + 1, 2).Value = aLinks(i)
  Next i
End If
End Sub

Excel konvertálása csv-be

Sub xls2csv()

kjev = Worksheets("ini").Range("G2")
vevo = Worksheets("ini").Range("A2") & ".txt"
  Sheets("db").Select
  Const DELIMITER As String = "|"
  Dim myRecord As Range
  kjfile = "Z:\konyvtar\" & kjev & "\txt\" & vevo
  Dim myField As Range
  Dim nFileNum As Long
  Dim sOut As String
   
  nFileNum = FreeFile
' Open "Test.txt" For Output As #nFileNum
  Open kjfile For Output As #nFileNum
  For Each myRecord In Range("A1:a" & _
  Range("a" & Rows.Count).End(xlUp).Row)
  With myRecord
  For Each myField In Range(.Cells, _
  Cells(.Row, Columns.Count).End(xlToLeft))
  sOut = sOut & DELIMITER & myField.Text
  Next myField
  Print #nFileNum, Mid(sOut, 2)
  sOut = Empty
  End With
  Next myRecord
  Close #nFileNum
End Sub