Estimados necesitaba hacer una función que entregue un valor de acuerdo a dos celdas y que luego de tener ese valor, en otra celda, busque en una columna si se repite el numero de una celda, después si se repite utilizar los valores de las columnas aledañas a las celdas en donde se encontraron igualdades para hacer un calculo de precio según el valor de estas.
Primero estuve tratando sin macros pero no se me ocurrió como. Después me ayudaron con esta macro que realiza el calculo en una planilla pequeña, ahora cuando intente realizarlo en la planilla real no pude. Adjunto planilla Ejemplo y planilla Real con la macro no funcionando.
Este es el macro que funciona en la planilla de ejemplo son 2 modulos...
Modulo 1
Option Explicit
Option Base 1
Function BUSCARV2(valor1, valor2, area As Range, columna As Integer)
'Stop
'Este proceso crea una funcion personalizada en la cual busca dos valores
Dim i As Long
Dim resultado As Variant
Dim dim1 As Integer
Dim dim2 As Integer
'dim1 guarda la cantidad de filas del area
dim1 = area.Rows.Count
'dim2 guarda la cantidad de columnas del area
dim2 = area.Columns.Count
For i = 1 To dim1
If area.Cells(i, 1).Value = valor1 Then
If area.Cells(i, 2).Value = valor2 Then
resultado = area.Cells(i, columna).Value
Exit For
End If
End If
Next i
BUSCARV2 = resultado
End Function
Function BUSCARV3(TRA As String, CAMION As Integer, qvale As Double) As Double
Estimados necesitaba hacer una función que entregue un valor de acuerdo a dos celdas y que luego de tener ese valor, en otra celda, busque en una columna si se repite el numero de una celda, después si se repite utilizar los valores de las columnas aledañas a las celdas en donde se encontraron igualdades para hacer un calculo de precio según el valor de estas.
Primero estuve tratando sin macros pero no se me ocurrió como. Después me ayudaron con esta macro que realiza el calculo en una planilla pequeña, ahora cuando intente realizarlo en la planilla real no pude. Adjunto planilla Ejemplo y planilla Real con la macro no funcionando.
Este es el macro que funciona en la planilla de ejemplo son 2 modulos...
Modulo 1
Option Explicit
Option Base 1
Function BUSCARV2(valor1, valor2, area As Range, columna As Integer)
'Stop
'Este proceso crea una funcion personalizada en la cual busca dos valores
Dim i As Long
Dim resultado As Variant
Dim dim1 As Integer
Dim dim2 As Integer
'dim1 guarda la cantidad de filas del area
dim1 = area.Rows.Count
'dim2 guarda la cantidad de columnas del area
dim2 = area.Columns.Count
For i = 1 To dim1
If area.Cells(i, 1).Value = valor1 Then
If area.Cells(i, 2).Value = valor2 Then
resultado = area.Cells(i, columna).Value
Exit For
End If
End If
Next i
BUSCARV2 = resultado
End Function
Function BUSCARV3(TRA As String, CAMION As Integer, qvale As Double) As Double
Stop
'Dim qvale As Double
Dim filas As Long
'qvale = Val(ActiveCell.Offset(0, -1))
Dim mD, d, SumPeso As Double
'filas = Application.WorksheetFunction.CountA("A1:A65000")
'mD = Range("A1:E1").Offset(filas, 0)
mD = Range("A2").CurrentRegion
For d = 2 To UBound(mD, 1)
If mD(d, 3) = TRA And _
mD(d, 4) = CAMION And _
mD(d, 5) = qvale Then
SumPeso = SumPeso + mD(d, 1)
End If
Next
BUSCARV3 = mD(d, 1) * qvale / SumPeso
End Function
Sub BUSCARxPRECIO()
Dim TRA As String, CAMION As Integer, qvale As Double
TRA = ActiveCell.Offset(0, -3)
CAMION = ActiveCell.Offset(0, -2)
qvale = ActiveCell.Offset(0, -1)
Dim mD, d, SumPeso As Double
mD = Range("A1").CurrentRegion
For d = 2 To UBound(mD, 1)
If mD(d, 3) = TRA And _
mD(d, 4) = CAMION And _
mD(d, 5) = qvale Then
SumPeso = SumPeso + mD(d, 1)
End If
Next
'BUSCARV3 = mD(d, 1) * qVALE / SumPeso
End Sub
Modulo 2
Option Explicit
Option Base 1
Sub BUSCARxVALOR()
Dim f
f = Application.WorksheetFunction.CountA(Range("E:E")) + 1
Range("AA:AX").ClearContents
Range("E2:F" & f).ClearContents
Dim mP
Dim p
Dim mX
Dim mS
Dim s
Dim v1
Dim v2
mP = Sheets("PROVEEDORES").Range("A1").CurrentRegion
mS = Sheets("SERVICIOS").Range("A1").CurrentRegion
mX = Sheets("SERVICIOS").Range("A1").CurrentRegion
For s = 2 To UBound(mS, 1)
For p = 1 To UBound(mP, 1)
If mS(s, 3) = mP(p, 1) And _
mS(s, 4) = mP(p, 2) Then
mS(s, 5) = mP(p, 3)
Exit For
End If
Next
Next
Range("A1").Resize(s - 1, 5) = mS
'Stop
ORDENAR
Application.ScreenUpdating = False
VALORESxUNICOS
IMPORTES
Range("AA:AX").ClearContents
Application.ScreenUpdating = True
End Sub
Sub IMPORTES()
Dim mS
Dim s
Dim abc
Dim mI, i
mS = Sheets("SERVICIOS").Range("A1").CurrentRegion
mI = Range("AA1").CurrentRegion
'ReDim Preserve mS(s, 6)
For s = 2 To UBound(mS, 1)
abc = mS(s, 2) & "_" & mS(s, 3) & "_" & mS(s, 4)
For i = 2 To UBound(mI, 1)
If abc = mI(i, 1) Then
'Stop
mS(s, 5) = mI(i, 3)
mS(s, 6) = mS(s, 1) * mI(i, 4)
Exit For
End If
Next
Next
Range("A1").Resize(s - 1, 6) = mS
End Sub
Sub VALORESxUNICOS()
Dim mS
Dim s
Dim abc As String, f As Long, r As Range
mS = Sheets("SERVICIOS").Range("A1").CurrentRegion
f = 1
abc = mS(f, 2) & "_" & mS(f, 3) & "_" & mS(f, 4)
Range("AA" & f) = abc
Range("AB" & f) = mS(f, 1)
Range("AC" & f) = mS(f, 5)
Range("AD" & f) = "Valor#"
For s = 2 To UBound(mS, 1)
abc = mS(s, 2) & "_" & mS(s, 3) & "_" & mS(s, 4)
On Error Resume Next
If Range("AA" & f) = abc Then
'Range("AB" & s - 1) = Range("AB" & s - 1) + mS(s, 5)
'n_a_d_a
Range("AB" & f) = mS(s, 1) + Range("AB" & f)
Else
f = f + 1
Range("AA" & f) = mS(s, 2) & "_" & mS(s, 3) & "_" & mS(s, 4)
Range("AB" & f) = mS(s, 1)
Range("AC" & f) = mS(s, 5)
End If
Next
'Stop
Set r = Range("AA1")
f = 0
Do
f = f + 1
If r.Offset(f, 0) = "" Then Exit Do
r.Offset(f, 3) = r.Offset(f, 2) / r.Offset(f, 1)
Loop
End Sub
Sub ORDENAR()
Dim f
f = Application.WorksheetFunction.CountA(Range("A:A"))
ActiveWorkbook.Worksheets("SERVICIOS").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("SERVICIOS").Sort.SortFields.Add Key:=Range("B2:B" & f _
), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("SERVICIOS").Sort.SortFields.Add Key:=Range("C2:C" & f _
), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("SERVICIOS").Sort.SortFields.Add Key:=Range("D2:D" & f _
), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("SERVICIOS").Sort
.SetRange Range("A1:F" & f)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Gracias Saludos
Planilla Real.xls
Ejemplo.xls