Macro per dividere numeri

[AndreaExcel]

Ciao a tutti,
ho un file Excel con più fogli.

Mi servirebbe una macro VBA che divida il contenuto delle colonne dalla H
alla AE di un foglio denominato “Data Sheet” (indipendentemente dal numero di
righe che non so a priori quali sarà in quanto risultante da un’estrazione
via ODBC) per il valore che si trova nel campo J2 del foglio “Parameter”.

Si può fare?

Grazie mille a tutti per l’aiuto.

Andrea

[Norman Jones]

Ciao Andrea,

'-----------------
ho un file Excel con più fogli.

Mi servirebbe una macro VBA che divida il contenuto delle colonne dalla H
alla AE di un foglio denominato "Data Sheet" (indipendentemente dal numero
di
righe che non so a priori quali sarà in quanto risultante da un'estrazione
via ODBC) per il valore che si trova nel campo J2 del foglio "Parameter".

Si può fare?
'-----------------

In un moduilo standard (vedi di sotto), prova:

'============>>
Public Sub Tester()
Dim WB As Workbook
Dim SH As Worksheet
Dim Rng As Range
Dim Rng2 As Range
Dim rCell As Range
Dim iLastRow As Long
Dim CalcMode As Long

Set WB = Workbooks("Pippo.xls") '<<=== da CAMBIARE
With WB
Set SH = .Sheets("Data Sheet") '<<=== da CAMBIARE
Set SH2 = .Sheets("parameter") '<<=== da CAMBIARE
End With

Set Rng = SH.Columns("H:AE") '<<=== da CAMBIARE
iLastRow = LastRow(SH, Rng)
Set Rng = Rng.Resize(iLastRow)
Set Rng2 = SH2.Range("J2") '<<=== da CAMBIARE

On Error GoTo XIT
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

For Each rCell In Rng.Cells
With rCell
If IsNumeric(.Value) _
And .Value <> 0 Then
.Value = .Value / Rng2.Value
End If
End With
Next rCell

XIT:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
End Sub
'<<============

Per utilizzare questa routine:

Alt-F11 per aprire l'Editor di VBA
Menu | Inserisci | Modulo
Incolla il suddetto codice
Alt-F11 per tornare in Excel
Alt-F8
Seleziona "Tester"
Esegui


---
Regards,
Norman
Microsoft Excel MVP

[Norman Jones]

Ciao Andrea,

Non ho incollato la funzione LastRow - chiiedo scusa!

Sostituisci il codice precedente con la seguente versione:

'============>>
Public Sub Tester()
Dim WB As Workbook
Dim SH As Worksheet
Dim Rng As Range
Dim Rng2 As Range
Dim rCell As Range
Dim iLastRow As Long
Dim CalcMode As Long

Set WB = Workbooks("Pippo.xls") '<<=== da CAMBIARE
With WB
Set SH = .Sheets("Data Sheet") '<<=== da CAMBIARE
Set SH2 = .Sheets("parameter") '<<=== da CAMBIARE
End With

Set Rng = SH.Columns("H:AE") '<<=== da CAMBIARE
iLastRow = LastRow(SH, Rng)
Set Rng = Rng.Resize(iLastRow)
Set Rng2 = SH2.Range("J2") '<<=== da CAMBIARE

On Error GoTo XIT
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

For Each rCell In Rng.Cells
With rCell
If IsNumeric(.Value) _
And .Value <> 0 Then
.Value = .Value / Rng2.Value
End If
End With
Next rCell

XIT:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
End Sub

'--------------->
Function LastRow(SH As Worksheet, _
Optional Rng As Range)
If Rng Is Nothing Then
Set Rng = SH.Cells
End If

On Error Resume Next
LastRow = Rng.Find(What:="*", _
After:=Rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
'<<============



---
Regards,
Norman
Microsoft Excel MVP

[AndreaExcel]

Ciao Norman, scusa la risposta tardiva:

tutto OK con la tua macro (mancava solo la dichiarazione di una variabile,
ma roba da poco), il mio problema è stato risolto!

Grazie Mille

Post by Norman Jones
Ciao Andrea,
Non ho incollato la funzione LastRow - chiiedo scusa!
'============>>
Public Sub Tester()
Dim WB As Workbook
Dim SH As Worksheet
Dim Rng As Range
Dim Rng2 As Range
Dim rCell As Range
Dim iLastRow As Long
Dim CalcMode As Long
Set WB = Workbooks("Pippo.xls") '<<=== da CAMBIARE
With WB
Set SH = .Sheets("Data Sheet") '<<=== da CAMBIARE
Set SH2 = .Sheets("parameter") '<<=== da CAMBIARE
End With
Set Rng = SH.Columns("H:AE") '<<=== da CAMBIARE
iLastRow = LastRow(SH, Rng)
Set Rng = Rng.Resize(iLastRow)
Set Rng2 = SH2.Range("J2") '<<=== da CAMBIARE
On Error GoTo XIT
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
For Each rCell In Rng.Cells
With rCell
If IsNumeric(.Value) _
And .Value <> 0 Then
.Value = .Value / Rng2.Value
End If
End With
Next rCell
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
End Sub
'--------------->
Function LastRow(SH As Worksheet, _
Optional Rng As Range)
If Rng Is Nothing Then
Set Rng = SH.Cells
End If
On Error Resume Next
LastRow = Rng.Find(What:="*", _
After:=Rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
'<<============
---
Regards,
Norman
Microsoft Excel MVP