Metodo range dell'oggetto worksheet non riuscito

[danrosPartecipante danros]

Ciao a tutti.

Sono abbastanza a digiuno di codice e mi trovo con alcuni fogli lasciati da un collega che non lavora più con me.

Ho due file con molte colonne di dati, il primo è il file origine, viene compilato a mano. Il secondo è il file destinazione e il codice deve scorrere l'origine e copiare i dati nuovi nel file destinazione con una mappatura di colonne ben precisa.

Il confronto viene eseguito confrontando la colonna B dove ho le date: Una riga ogni data.

Mi sono accorto che allungando la tabella del file origine, arrivando a date successive a quanto presente nel file destino (esempio di oggi: Origine termina con il 2/2/2023, il file destino termina con il 01/01/2022) mi si presenta nel codice di seguito il problema: Metodo range dell'oggetto Worksheet non riuscito.

If intRiga_O_Inizio = 0 Or shtOrigine.Range("K" & intRiga_O_Fine) = vbNullString Then

La porzione di codice è:

    If intRiga_O_Inizio = 0 Or shtOrigine.Range("K" & intRiga_O_Fine) = vbNullString Then
    Application.ScreenUpdating = True
      msgbox "Non ci sono nuovi dati da importare", vbInformation
      Exit Sub
    End If

Se accorcio il file origine a data = o < del file destino tutto funziona.

Qualcuno mi può spiegare il motivo del blocco?

Grazie

 

Tutto il codice è il seguente

Global g_NomeFoglioDestinazione As String
Public g_NomeFile As String

Sub Carica_Dati_Origine_cloud()
'
' CopiaDatiOrigine Macro
'

    Dim strPath As String
    Dim strNomeFile As String
    Dim strNomeFileCompleto As String
    Dim ultData As Date
    Dim wbkOrigine As Workbook
    Dim shtOrigine As Worksheet
    Dim strNomeFoglioDest As String
    Dim shtDestinazione As Worksheet
    Dim blEsito As Boolean
    Dim intRiga_O_Inizio As Integer
    Dim intRiga_O_Fine As Integer
    Dim intRiga_D_Inizio As Integer
    Dim datUltima   As Date
    Dim rngO As Range
    Dim CellaData_O As String
    Dim blTrovato As Boolean
    Dim blFoglioAperto As Boolean
    Dim offSet_Campo1_O As Integer
    Dim offSet_Campo1_D As Integer
    Dim strValoreCellaOrig As String
    Dim rngD As Range
    Dim CellaData_D As String
    Dim arrO() 'As String
    Dim arrD() 'As String
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim strNomeFoglioOrigine As String
    Dim strPrimoCampoMappa As String
    Dim strColonnaData_O As String
    Dim intRigaInizio_O As Integer
    Dim intNumeroCampiDaCopiare As Integer
    Dim UValOrig As String
        
    '**************************************
    '    Compilare i dati con <---        '
    '**************************************

'' si piazza sul file destinazione
'    Windows(strNomeFileDest).Activate
' SBlocca l'esecuzione dei calcoli
    Application.Calculation = xlAutomatic ' in alternativa xlManual

    'Chiede se aggiornare i filtri
    Dim risp4 As String
    risp4 = msgbox("Aggiornare filtri?" & vbCrLf & vbCrLf & "filtri?", _
    vbQuestion + vbYesNo + vbDefaultButton2, "Funzione MsgBox Semplice")
    If risp4 = vbNo Then
      GoTo FineFiltro
    End If
    
'    With ActiveWorkbook.SlicerCaches("FiltroDati_Filtro")
'      .SlicerItems("Ok").Selected = True
'      .SlicerItems("F").Selected = False
'      .SlicerItems("V").Selected = False
'    End With
'
'    With ActiveWorkbook.SlicerCaches("FiltroDati_Filtro_uso_report_gasolio")
'      .SlicerItems("Ok").Selected = True
'      .SlicerItems("F").Selected = False
'      .SlicerItems("V").Selected = False
'    End With
'
'    With ActiveWorkbook.SlicerCaches("FiltroDati_Filtro4")
'      .SlicerItems("Ok").Selected = True
'      .SlicerItems("F").Selected = False
'      .SlicerItems("V").Selected = False
'    End With
'
'    With ActiveWorkbook.SlicerCaches("FiltroDati_Filtro3")
'      .SlicerItems("Ok").Selected = True
'      .SlicerItems("F").Selected = False
'      .SlicerItems("V").Selected = False
'    End With
'
'    With ActiveWorkbook.SlicerCaches("FiltroDati_Filtro1")
'      .SlicerItems("Ok").Selected = True
'      .SlicerItems("F").Selected = False
'      .SlicerItems("V").Selected = False
'    End With

FineFiltro:


    strNomeFileDest = ActiveWorkbook.Name 'strPathDest & strNomeFileDest
    Set shtDestinazione = ActiveSheet
    
'    strPath = "C:\Users\xxx.xxx\Dropbox\yyy.yyy\"    'nel caso di dropbox
    strPath = "D:\OneDrive\yyy.yyy\"                             'nel caso di onedrive
    strNomeFile = "letture xxx x - Cloud.xlsm"
    strNomeFoglioOrigine = "LettMan" '  <--- nome del foglio con i dati
    
    'Prima di eseguire chiede di sincronizzare i file presenti sul server:
    'salva
  'wbkDest.Save
  
    'Apre il programma di sincronizzazione  ' Era: ' Vuoi aprire il programma di sincronizzazione?
                                              'Dim risp2 As String
                                              'risp2 = MsgBox("          Prima di importare." & vbCrLf & vbCrLf & "Vuoi aprire la sincronizzazione?", vbQuestion + vbYesNo, "Funzione MsgBox Semplice")
                                              'If risp2 = vbYes Then
    If risp4 = vbYes Then
      Apri_Sincro_file_dogane
    End If
        Dim risp3_chiudi As String
        risp3_chiudi = msgbox("          Programma sincro aperto." & vbCrLf & vbCrLf & "Vuoi procedere con l'importazione dati?", _
        vbQuestion + vbYesNo + vbDefaultButton1, "Funzione MsgBox Semplice")
        
        If risp3_chiudi = vbNo Then
          Exit Sub
        End If
      'wbkDest.Close (True)
    'End If
'procede
    
    'Verifica se foglio già aperto
    For i = 1 To Workbooks.Count
      If Workbooks(i).Name = strNomeFile Then
        blFoglioAperto = True
        Exit For
      End If
    Next i
    
    
    'se aperto imposta i riferimenti
    If blFoglioAperto Then
      Set wbkOrigine = Workbooks(i)
    Else
'    Application.ScreenUpdating = False

      '..lo apre
      strNomeFileCompleto = strPath & strNomeFile ' <--- nome del file con i dati
      
      'Se il file non c'è avvisa ed esce
      If Dir(strNomeFileCompleto) <> "" Then
      Else
          msgbox "Il file specificato come Origine dati non esiste o è stato spostato", vbCritical
          Exit Sub
      End If
      Set wbkOrigine = Workbooks.Open(strNomeFileCompleto, False, True)
    
    End If
'
'si piazza sul file destinazione
    Windows(strNomeFileDest).Activate
'' Blocca l'esecuzione dei calcoli
    Application.Calculation = xlManual ' in alternativa xlAutomatic
      
      
    Set shtOrigine = wbkOrigine.Sheets(strNomeFoglioOrigine)
    
    arrO = Array("C", "D", "E", "F", "G", "H", "J", "K", "L", "M", "N", "O", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "aa", "ab", "ac", "ad", "ae", "af", "ag", "ah", "ai", "aj", "ak", "al", "am", "an", "ao", "ap") ' <-- Origine
    arrD = Array("C", "D", "E", "F", "G", "H", "CQ", "K", "L", "AR", "M", "N", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", "aa", "ab", "ac", "ad", "ae", "af", "ag", "ah", "ai", "aj", "ak", "al", "am", "an", "ao") ' <-- Destinazione
   
      
    If UBound(arrO()) <> UBound(arrD()) Then
      msgbox "Il numero di campi di Origine NON corrisponde al numero campi destinazione", vbExclamation
      Exit Sub
    End If
    
    intNumeroCampiDaCopiare = UBound(arrO) + 1
    
    
    '**************************************
    '    VERIFICA SE CI SONO DATI NUOVI
    '**************************************
    
    
    
    'legge ultima data compilata
    strColonnaData_O = "B"  '  <--- Prima cella del foglio di Origine contenente la Data
    intRigaInizio_O = 5  ' <-- numero di riga su Origine dove iniziano i Dati
    CellaData_O = "B5"   ' <-- rif alla cella su Origine contenente la data da controllare (1a riga)
    CellaData_D = "B8"   ' <-- rif alla cella su Destinazione contenente la data da controllare (1a riga)
    offSet_Campo1_D = 9  ' <-- num di colonne di 'distanza' tra la colonna data e colonna con dato significativo da controllare

    blEsito = LeggeUltimaDataDestinazione(shtDestinazione, intRiga_D_Inizio, datUltima, CellaData_D, offSet_Campo1_D)
    If Not blEsito Then
      msgbox "Si è verificato un errore in LeggeUltimaDataDestinazione ", vbCritical
      Exit Sub
    End If
    
    'Si posiziona su prima riga Origine successiva a data ultima
    Set rngO = shtOrigine.Range(CellaData_O)
    
    
    offSet_Campo1_O = 10 ' <-- num di colonne di 'distanza' tra la colonna data e colonna con dato significativo da controllare
    intRiga_O_Fine = 0
    intRiga_O_Inizio = 0
    
    i = shtOrigine.UsedRange.Rows.Count
    
    blTrovato = False
    Do While Not blTrovato And i >= intRigaInizio_O
        Set rngO = shtOrigine.Range(strColonnaData_O & i)
        strValoreCellaOrig = rngO.Offset(, offSet_Campo1_O)
        'se esiste un valore valido imposta esito ed esce
        If strValoreCellaOrig > vbNullString Then
            If intRiga_O_Fine = 0 Then intRiga_O_Fine = i
            If rngO.Value > datUltima Then
                intRiga_O_Inizio = i
            Else
                blTrovato = True
            End If
        Else
            If IsDate(rngO) And rngO <= datUltima Then
                blTrovato = True
            End If
              intRiga_O_Inizio = i
        End If
        i = i - 1
    Loop
       
    'se non trovato avvisa ed esce
'
'    If intRiga_O_Inizio = 0 Or intRiga_O_Fine = 0 Then
'      Application.ScreenUpdating = True
'      msgbox "Non ci sono nuovi dati da importare", vbInformation
'      Exit Sub
'    Else
'      If shtOrigine.Range("K" & intRiga_O_Fine) = vbNullString Then
'        Application.ScreenUpdating = True
'        msgbox "Non ci sono nuovi dati da importare", vbInformation
'        Exit Sub
'      End If
'    End If


    If intRiga_O_Inizio = 0 Or shtOrigine.Range("K" & intRiga_O_Fine) = vbNullString Then
    Application.ScreenUpdating = True
      msgbox "Non ci sono nuovi dati da importare", vbInformation
      Exit Sub
    End If
        
    '**********************************
    '    COPIA DEI DATI
    '**********************************
    
    
    'Inizia il ciclo leggi-scrivi
    
    k = 0
    With rngO
        For i = intRiga_O_Inizio To intRiga_O_Fine
            k = k + 1
            For j = 0 To intNumeroCampiDaCopiare - 1
                
                If shtOrigine.Range(arrO(j) & i).Value <> vbNullString Then
                  Set rngD = shtDestinazione.Range(arrD(j) & intRiga_D_Inizio + k)
                  rngD.Value = shtOrigine.Range(arrO(j) & i).Value
                  rngD.Font.ColorIndex = 1

                End If
            
            Next j
          
'          shtDestinazione.Cells(intRiga_D_Inizio + k, 46).Formula = _
                      "=IF(NOT(OR(ISNUMBER([@[ S1 ]]),ISNUMBER([@[ S2 ]]),ISNUMBER([@[ S3 ]]))),"""",IF(+[@[s1_gL]]+[@[s2_gL]]+[@[s3_gL]]=0,0,+[@[s1_gL]]+[@[s2_gL]]+[@[s3_gL]]))"
          
          If shtDestinazione.Cells(intRiga_D_Inizio + k, 16) Or Cells(intRiga_D_Inizio + k, 17) Or Cells(intRiga_D_Inizio + k, 18) > 0 Then
            Application.Calculation = xlAutomatic ' in alternativa xlManual / sblocca l'esecuzione dei calcoli
            shtDestinazione.Cells(intRiga_D_Inizio + k, 46).Formula = _
                      "=IF(NOT(OR(ISNUMBER([@[ S1 ]]),ISNUMBER([@[ S2 ]]),ISNUMBER([@[ S3 ]]))),"""",IF(+[@[s1_gL]]+[@[s2_gL]]+[@[s3_gL]]=0,0,+[@[s1_gL]]+[@[s2_gL]]+[@[s3_gL]]))"
          End If
            Application.Calculation = xlManual ' in alternativa xlAutomatic '' Blocca l'esecuzione dei calcoli
            
        Next i
    End With

'   SBlocca l'esecuzione dei calcoli
    Application.Calculation = xlAutomatic ' in alternativa xlManual

    Dim AR As Integer
      For AR = intRiga_D_Inizio To intRiga_D_Inizio + k
        Cells(AR, 95).Select
          If Cells(AR, 95).Value > 999.6 Then
            msgbox ("Produzione troppo elevata in data " & Cells(AR, 2))
            Cells(AR, 9).Select
            GoTo finecontrollo
          End If
      Next AR
    
    
'            Application.Calculation = xlManual ' in alternativa xlAutomatic '' Blocca l'esecuzione dei calcoli
    Cells(intRiga_D_Inizio + k + 1, "L").Select
    
    'Ciclo tutte le PivotTable e le aggiorno
    ThisWorkbook.RefreshPivotTables

    'Libera memoria
    Set rngO = Nothing
    Set rngD = Nothing
    
    Set shtOrigine = Nothing
    If Not blFoglioAperto Then
      wbkOrigine.Close False
    End If
    Set wbkOrigine = Nothing
    Set shtDestinazione = Nothing
    
    Application.ScreenUpdating = True

    msgbox "Importazione e calcoli eseguita"

finecontrollo:

End Sub
Private Function LeggeUltimaDataDestinazione(ByRef rWsh As Worksheet, ByRef rRiga As Integer, ByRef rDataUlt As Date, ByVal strCella As String, vOffsetData) As Boolean

    Dim i As Integer
    Dim dataUlt As Date


    On Error GoTo Err_LeggeUltimaDataDestinazione


    'Legge ultima data compilata nel foglio DatiImp



    'Inizializza
    rRiga = rWsh.UsedRange.Rows.Count
    rDataUlt = CDate("2000/01/01")

    With rWsh.Range(strCella)

        i = rWsh.UsedRange.Rows.Count

        Do
            If IsDate(.Offset(i)) Then
              If (.Offset(i, vOffsetData)) > "" Then
                  rDataUlt = .Offset(i).Value
                  rRiga = rWsh.Range(strCella).Row + i
                  Exit Do
              End If
            End If
            i = i - 1
        Loop

    End With



    'Imposta esito
    LeggeUltimaDataDestinazione = True

Exit_LeggeUltimaDataDestinazione:
    Exit Function

Err_LeggeUltimaDataDestinazione:

    msgbox Err.Description, vbCritical
    Resume
    LeggeUltimaDataDestinazione = False
    Resume Exit_LeggeUltimaDataDestinazione

End Function

 

[OscarPartecipante Oscar Karma: 32 pts]

Hai allegato un romanzo

[robbyPartecipante robby Karma: 2 pts]

danros ha scritto:

Tutto il codice è il seguente

Il codice non serve a nulla senza il file.
Se vuoi sperare in una soluzione, devi allegare il file Excel.

[Raffaele53Partecipante Raffaele53 Karma: 13 pts]

Forse per errore hai scambiato le due variabili?
Dim intRiga_O_Inizio As Integer
Dim intRigaInizio_O As Integer (in riga200)

Metti sotto la riga >>>Loop
Msgbox intRiga_O_Fine
e vedi cosa risponde

[Autore]

Articoli