Posts by nilem

Sub ertert()
Dim x, i&, j&, k&
With Sheets("Database")
    If .FilterMode Then .ShowAllData
    x = .Range("A1:C" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
End With


With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(x)
        If .Exists(x(i, 1)) Then
            k = .Item(x(i, 1))
            If InStr(x(k, 2), x(i, 2)) = 0 Then x(k, 2) = x(k, 2) & ", " & x(i, 2)
            If InStr(x(k, 3), x(i, 3)) = 0 Then x(k, 3) = x(k, 3) & ", " & x(i, 3)
        Else
            j = j + 1: .Item(x(i, 1)) = j
            x(j, 1) = CStr(x(i, 1))
            x(j, 2) = x(i, 2)
            x(j, 3) = x(i, 3)
        End If
    Next i
End With


With Sheets("Summary")
    .UsedRange.ClearContents
    .Range("B2:D2").Resize(j).Value = x
    .Activate
End With
End Sub

Function Kramerica2(rA As Range, rB As Range, rC As Range)
Dim a, b, c, i&, s$, t$
a = rA.Value
b = rB.Value
c = rC.Value


For i = 1 To UBound(a, 2)
    t = "~" & a(1, i) & b(1, i) & c(1, i)
    If InStr(t, 0) = 0 Then If InStr(s, t) = 0 Then s = s & t
    t = "~" & a(1, i) & b(2, i) & c(1, i)
    If InStr(t, 0) = 0 Then If InStr(s, t) = 0 Then s = s & t
Next i
Kramerica2 = Application.Transpose(Split(Mid(s, 2), "~"))
End Function

Function Kramerica(rA As Range, rB As Range, rC As Range)
Dim a, b, c, i&, s$
a = rA.Value
b = rB.Value
c = rC.Value


For i = 1 To UBound(a, 2)
    If InStr(s, "~" & a(1, i) & b(1, i) & c(1, i)) = 0 Then s = s & "~" & a(1, i) & b(1, i) & c(1, i)
    If InStr(s, "~" & a(1, i) & b(2, i) & c(1, i)) = 0 Then s = s & "~" & a(1, i) & b(2, i) & c(1, i)
Next i
Kramerica = Application.Transpose(Split(Mid(s, 2), "~"))
End Function

Function ElNino(rng As Range) As Long
Dim rBg As Range, x, i&, j&, cD&, cnt&
x = Intersect(rng.Parent.UsedRange, rng).Value
For i = 1 To UBound(x)
    For j = 1 To UBound(x, 2)
        If Len(x(i, j)) Then
            If x(i, j) > 0.5 Then
                cD = cD + 1
            Else
                If cD >= 5 Then cnt = cnt + 1
                cD = 0
            End If
        End If
    Next j
Next i
ElNino = cnt
End Function

Sub ertert()
Dim r As Range, rBg As Range, rSm As Range
With Range("A1:H59")
    .Interior.Color = xlNone
    For Each r In .Cells
        If r.Value > 0.5 Then
            If rBg Is Nothing Then Set rBg = r Else Set rBg = Union(rBg, r)
            If rBg.Count >= 5 Then rBg.Interior.ColorIndex = 43
            Set rSm = Nothing
        ElseIf r.Value < -0.5 Then
            If rSm Is Nothing Then Set rSm = r Else Set rSm = Union(rSm, r)
            If rSm.Count >= 5 Then rSm.Interior.ColorIndex = 46
            Set rBg = Nothing
        Else
            Set rSm = Nothing
            Set rBg = Nothing
        End If
    Next
End With
End Sub

Sub ertert()
Dim calc&
With Application
    calc = .Calculation: .ScreenUpdating = False: .Calculation = xlCalculationManual
End With
With Range("A1:B" & Cells(Rows.Count, 1).End(xlUp).Row)
    .Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlYes
    .Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(2), SummaryBelowData:=True
    .CurrentRegion.ClearOutline
End With
With Application
    .ScreenUpdating = False: .Calculation = calc
End With
End Sub

Sub ertert()
Dim x, i&, j&, k&, n&
With Sheets("Componentes")
    x = .Range("A1:V" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
End With: j = 2


With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 3 To UBound(x)
        If .Exists(x(i, 1)) Then
            n = .Item(x(i, 1))
            For k = 1 To UBound(x, 2)
                If IsEmpty(x(n, k)) Then x(n, k) = x(i, k)
            Next k
        Else
            j = j + 1: .Item(x(i, 1)) = j
            For k = 1 To UBound(x, 2)
                x(j, k) = x(i, k)
            Next k
        End If
    Next i
End With


With Sheets("Componentes")
    .UsedRange.ClearContents
    .Range("A1:V1").Resize(j).Value = x
End With
End Sub

Function CorrelWD(ByVal Rx As Range, Ry As Range) As Double
Dim sX As Double, sY As Double, sXX As Double, sYY As Double, sXY As Double, N As Long
Dim i As Long, stemp As Double, Yi As Double
Dim x, y
x = Rx.Value
y = Ry.Value


For i = 1 To UBound(y)
    If x(i, 1) <> "" And y(i, 1) <> "" Then
        'correct y
        stemp = y(i, 1) - x(i, 1)
        Yi = x(i, 1) + stemp + IIf(stemp < -180, 360, IIf(stemp > 180, -360, 0))


        'calculate the stats
        N = N + 1
        sX = sX + x(i, 1)
        sXX = sXX + x(i, 1) * x(i, 1)
        sY = sY + Yi
        sYY = sYY + Yi * Yi
        sXY = sXY + x(i, 1) * Yi
    End If
Next i
......

Sub ertert()
Dim x, y(), i&, j&, t(), r&, c&
x = Sheets("Foaie1").Range("A2").CurrentRegion.Value
ReDim y(1 To UBound(x, 1) * UBound(x, 2), 1 To 2): c = 2
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(x)
        For j = 1 To UBound(x, 2)
            If Len(x(i, j)) Then
                If Not .Exists(x(i, j)) Then
                    .Item(x(i, j)) = Array(i, j)
                Else
                    t = .Item(x(i, j))
                    If t(0) * t(1) Then
                        If c = 1 Then c = 2 Else c = 1: r = r + 1
                        y(r, c) = x(i, j)
                        x(t(0), t(1)) = ""
                        t(0) = 0: t(1) = 0: .Item(x(i, j)) = t()
                    End If
                    If c = 1 Then c = 2 Else c = 1: r = r + 1
                    y(r, c) = x(i, j): x(i, j) = vbNullString
                End If
            End If
        Next j
    Next i
End With
Sheets("Foaie1").Range("A2").Resize(i - 1, j - 1).Value = x
If r > 0 Then Sheets("Foaie2").Range("A2").Resize(r, 2).Value = y()
End Sub

Sub ertert()
Dim x, y(), i&, j&, t(), bu As Boolean
x = Sheets("Foaie1").Range("A2").CurrentRegion.Value
ReDim y(1 To UBound(x), 1 To UBound(x, 2))
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(x)
        For j = 1 To UBound(x, 2)
            If Len(x(i, j)) Then
                If .Exists(x(i, j)) Then
                    t = .Item(x(i, j)): bu = True
                    y(t(0), t(1)) = x(i, j): y(i, j) = x(i, j)
                    x(i, j) = "": x(t(0), t(1)) = ""
                Else
                    .Item(x(i, j)) = Array(i, j)
                End If
            End If
        Next j
    Next i
End With
Sheets("Foaie1").Range("A2").Resize(i - 1, j - 1).Value = x
If bu Then Sheets("Foaie2").Range("A2").Resize(i - 1, j - 1).Value = y()
End Sub