Macro per trasformare un copia incolla in numero assoluto

Question

Buongiorno,

ho due file excel uno Totali.xlsm e uno Parziali.xlsm e devo copiare da Parziali.xlsm la selezione A326,F326 che contiene in F326 un numero negativo e copiarla in Totali.xlsm folgio1 nella prima cella libera trasformando il dato negativo in positivo. Usando il registratore macro ottengo questo che però va bene solo la prima volta mentre le seguenti operazioni oltre a sovrascrivere sempre in B2105 mi ricopiano sempre il solito valore 28417.16. Qualcuno mi sa dire come dirle qualunque valore in F326 deve diventare positivo e copiare nella prima cella libera.

Grazie

    ChDir "U:\DOC\DatabaseEst"

    Workbooks.Open Filename:= _

        "U:\DOC\DatabaseEst\Parziali.xlsm"

    Sheets("foglio2").Select

    Windows("Totali.xlsm").Activate

    ActiveWindow.SmallScroll Down:=-90

    Windows("Parziali.xlsm").Activate

    Range("A326,F326").Select

    Range("F326").Activate

    Selection.Copy

    Windows("Totali.xlsm").Activate

    ActiveWindow.SmallScroll Down:=108

    Range("A2105").Select

    ActiveSheet.Paste

    Range("B2105").Select

    Application.CutCopyMode = False

    ActiveCell.FormulaR1C1 = "28417.16"

    Range("B2106").Select

Answer 1

Ciao Pallitta,

se ho interpretato bene potrebbe essere:

' Modulo: Macro

'

Option Explicit

Public Sub CopiaParzialiInTotali()

Const cPrc$ = "CopiaParzialiInTotali"

On Error GoTo ErrH

' --- Personalizzare ---------- >

'

Const cstrParzialiPath$ = "U:\DOC\DatabaseEst"

Const cstrParzialiName$ = "Parziali.xlsm"

Const cstrParzialiSheet$ = "Foglio2"

Const cstrParzialiRange$ = "A326:F326"

Const cstrTotaliPath$ = "U:\DOC\DatabaseEst"

Const cstrTotaliName$ = "Totali.xlsm"

Const cstrTotaliSheet$ = "Foglio1"

Const cstrTotaliRange$ = "A1"

'

' ---------- Personalizzare --- <

Dim wbkSrc  As Excel.Workbook

Dim wshSrc  As Excel.Worksheet

Dim rngSrc  As Excel.Range

Dim wbkDst  As Excel.Workbook

Dim wshDst  As Excel.Worksheet

Dim rngDst  As Excel.Range

    If MsgBox("Copia da Parziali in Totali in corso..." _

            & vbNewLine & "Confermi?" _

            , vbOKOnly Or vbQuestion _

            , cPrc _

            ) <> vbOK Then Exit Sub

    Set wbkSrc = GetWorkbookByName(cstrParzialiPath, cstrParzialiName)

    Set wshSrc = wbkSrc.Worksheets(cstrParzialiSheet)

    Set rngSrc = wshSrc.Range(cstrParzialiRange)

    Set wbkDst = GetWorkbookByName(cstrTotaliPath, cstrTotaliName)

    Set wshDst = wbkDst.Worksheets(cstrTotaliSheet)

    Set rngDst = wshDst.Range(cstrTotaliRange)

    With rngDst

      Set rngDst = .Worksheet.Cells(.EntireColumn.Rows.Count _

                                  , .Column).End(xlUp).Offset(1)

    End With

    rngSrc.Copy rngDst

    With rngDst.Offset(0, rngSrc.Columns.Count - 1)

      .Value = Abs(.Value)

    End With

ExtP:

    On Error Resume Next

    Set rngDst = Nothing

    Set wshDst = Nothing

    Set wbkDst = Nothing

    Set rngSrc = Nothing

    Set wshSrc = Nothing

    Set wbkSrc = Nothing

    Exit Sub

ErrH:

    With Err

      MsgBox "ERRORE#" & CStr(.Number) & vbNewLine & .Description _

           , vbOKOnly Or vbCritical _

           , cPrc

    End With

    Resume ExtP

End Sub

Private Function GetWorkbookByName(ByVal WorkbookPath As String _

                                 , ByVal WorkbookName As String _

                                 ) As Excel.Workbook

    On Error Resume Next

    With Application.Workbooks

      Set GetWorkbookByName = .Item(WorkbookName)

      If Err.Number Then Set GetWorkbookByName = .Open(WorkbookPath _

                                                     & WorkbookName)

    End With

End Function

Answer 2

Grazie a te, Pallitta, del cortese riscontro.

Answer 3

perfetto grazie mille