Cambio range ciclo for

Hai un problema con Excel?

Nuova discussione

Cambio range ciclo for
di Gabor (utente non iscritto) data: 25/09/2013 13:08:47
Salve a tutti,

Premetto che sono abbastanza alle prime armi con il codice VBA ma avrei un problema con una macro che non riesco veramente a risolvere.
Lo scopo di questa consiste nel copiare dai worksheets alcune colonne che hanno lunghezza variabile a seconda dei ws stessi, ma, per ognuno di questi ultimi, le colonne interessate hanno tutte la medesima lunghezza.

Le colonne "C:C" ed "E:E" presentano tutte le celle compilate mentre "BS:BS" e "BT:BT" possono avere o non avere nei valori all'interno celle. Il risultato finale dovrebbe presentarsi in modo tale che fino all'i-esima riga della colonna C compilata, di fianco devono corrispondere le relative celle [E:i], [BS:i] e [BT,i]

Ho imposto un numero limite di 1000 righe per il ciclo poiché solitamente ogni foglio contiene tra le 300 e le 700 righe ed avendo più cartelle di lavoro dove applicare questa macro, non mi è possibile fare una selezione puntuale.

Gli ultimi due cicli for, relative appunto alle colonne BS e BT, sono quelli problematici.
Ora come ora non sono ancora riuscito a fare in modo che, giunto all'ultima riga in cui la colonna C risulta compilata (i-esima riga), il range su cui effettuare gli ultimi due cicli for si riducano appunto al range "BS3:BS(i)" e "BT3:BT(i)".

Qualcuno potrebbe darmi qualche idea?

Sub Summary_All2()

    Dim Sh As Worksheet
    Dim Newsh As Worksheet
    Dim myCell As Range
    Dim ColNum As Long
    Dim RwNum As Integer
    Dim iSup As Integer
    Dim Basebook As Workbook

           
    

    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    
    Application.DisplayAlerts = False
    On Error Resume Next
    ThisWorkbook.Worksheets("Summary-Sheet2").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    
    Set Basebook = ThisWorkbook
    Set Newsh = Basebook.Worksheets.Add
    Newsh.Name = "Summary-Sheet2"


    iSup = 1
    RwNum = 1

    For Each Sh In Basebook.Worksheets
        If Sh.Name <> Newsh.Name And Sh.Visible Then
        
            ColNum = 2
            iSup = RwNum
            
            For Each myCell In Sh.Range("c3:c1000")
                If (myCell <> "") Then
                iSup = iSup + 1
                Newsh.Cells(iSup, ColNum).Formula = "='" & Sh.Name & "'!" & myCell.Address(False, False)
                End If
            Next myCell
              
                  
            iSup = RwNum
            ColNum = ColNum + 1
            
            For Each myCell In Sh.Range("E3:E1000")
                If (myCell <> "") Then
                iSup = iSup + 1
                Newsh.Cells(iSup, ColNum).Formula = "='" & Sh.Name & "'!" & myCell.Address(False, False)
                End If
            Next myCell
            
            iSup = RwNum
            ColNum = ColNum + 1
            
            For Each myCell In Sh.Range("Bs3:Bs1000")    'PROBLEMATICA
                iSup = iSup + 1
                If (myCell <> "") Then
                Newsh.Cells(iSup, ColNum).Formula = "='" & Sh.Name & "'!" & myCell.Address(False, False)
                End If
            Next myCell
            
            iSup = RwNum
            ColNum = ColNum + 1
            
            For Each myCell In Sh.Range("BT3:BT1000")  'PROBLEMATICA
                iSup = iSup + 1
                If (myCell <> "") Then
                Newsh.Cells(iSup, ColNum).Formula = "='" & Sh.Name & "'!" & myCell.Address(False, False)
                End If
            Next myCell
            
            RwNum = iSup
            
        End If
    Next Sh

    Newsh.UsedRange.Columns.AutoFit

    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub

di Grograman (utente non iscritto) data: 25/09/2013 15:06:23
Variante, manca solo da implementare l'eliminazione delle celle vuote dopo aver messo le formule.
Se posti un file di esempio invece la facciamo per bene ^_^

Option Explicit

Sub Summary_All2()

    Dim wb As Workbook
    Dim ws As Worksheet, wsNew As Worksheet
    Dim myCell As Range
    Dim ColNum As Long
    Dim RwNum As Long, iSup As Long, x As Long

  

    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
    Application.DisplayAlerts = 0
    Set wb = ThisWorkbook
    For Each ws In wb.Worksheets
      If ws.Name = "Summary-Sheet2" Then
        ws.Delete
        Exit For
      End If
    Next ws
    Application.DisplayAlerts = 1

    Set wsNew = wb.Worksheets.Add
    wsNew.Name = "Summary-Sheet2"


    iSup = 1
    RwNum = 1

    For Each ws In wb.Worksheets
      If ws.Name <> wsNew.Name And ws.Visible Then
        With ws
          x = .Range("C" & .Rows.Count).End(xlUp).Row
          iSup = wsNew.Range("C" & wsNew.Rows.Count).End(xlUp).Row + 1
          wsNew.Range("B2:B" & iSup + x).FormulaR1C1 = "='" & .Name & "'!" & "R[1]C[1]"
          
          x = .Range("E" & .Rows.Count).End(xlUp).Row
          iSup = wsNew.Range("C" & wsNew.Rows.Count).End(xlUp).Row + 1
          wsNew.Range("C2:C" & iSup + x).FormulaR1C1 = "='" & .Name & "'!" & "R[1]C[1]"
          
          x = .Range("BS" & .Rows.Count).End(xlUp).Row
          iSup = wsNew.Range("C" & wsNew.Rows.Count).End(xlUp).Row + 1
          wsNew.Range("D2:E" & iSup + x).FormulaR1C1 = "='" & .Name & "'!" & "R[1]C[67]"
        End With
      End If
    Next ws

    wsNew.Columns.AutoFit

    With Application
      .Calculation = xlCalculationAutomatic
      .ScreenUpdating = True
    End With
End Sub

di Gabor (utente non iscritto) data: 25/09/2013 15:37:55
Mi sono espresso abbastanza male prima, chiedo venia.
Nel foglio di riepilogo "Summary-Sheet2" i dati dei vari fogli dovrebbero comparire uno sotto l'altro.
Ti allego un file di esempio come da te richiesto ^^

Grazie per la disponibilità comunque :)

PS
Questa parte qua, non dovrebbe avere "R[1]C[2]"?

x = .Range("E" & .Rows.Count).End(xlUp).Row
iSup = wsNew.Range("C" & wsNew.Rows.Count).End(xlUp).Row + 1
wsNew.Range("C2:C" & iSup + x).FormulaR1C1 = "='" & .Name & "'!" & "R[1]C[1]"
di Grograman (utente non iscritto) data: 26/09/2013 09:18:53
Non vedo macro, nè i fogli richiamati dalla stessa, nel file allegato, che è un .xlsx tra l'altro.

Su su un piccolo sforzo!
di Gabor (utente non iscritto) data: 26/09/2013 15:11:35
Ti ho allegato un secondo file comprendente sia la macro che avevo fatto io sia quella che mi hai passato sia un foglio riepilogativo "RISULTATO SPERATO" il quale rappresenterebbe la versione finale dell'output alla quale vorrei arrivare.
Naturalmente entrambe le macro sono state rivisitate un attimo per questo file di prova.

PS.
Il file è un .xlsm poiché lavoro sulla versione di Excel2010.
di Gabor (utente non iscritto) data: 30/09/2013 10:17:37
Per caso qualcuno di voi ha qualche altra idea? Non sono ancora riuscito a risolvere la questione
di Grograman data: 30/09/2013 10:38:11
Ciao!

non vedo alcun file allegato :(
di Gabor (utente non iscritto) data: 30/09/2013 15:21:01
Ciao Grograman!

Ho riallegato il file che mi avevi richiesto. Credo che in questo forum gli allegati vengano svuotati dopo 48 ore o qualcosa di simile.

Vuoi Approfondire?