Adaptar código macro de una planilla a otra

[zesar]

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