Macro per riempire il foglio 2 con i dati del foglio 1 se contengono un determinato valore

Question

Buongiorno,

mi servirebbe un aiuto per creare una macro che mi riempia alcune colonne del foglio 2  a seconda dei valori riportati nel foglio 1. Mi spiego meglio, nel foglio 1 ho una tabella del tipo

					Q1	Q2	Q3	Q4
Spesa1					1	0	0	1
Spesa2					0	1	0	0
Spesa3					0	1	0	0
Spesa4					0	0	0	1
Spesa5					1	0	0	0
Spesa6					0	0	1	0
Spesa7					0	0	0	0
Spesa8					0	0	0	1
Spesa9					0	0	0	0
Spesa10					0	1	0	0
Spesa11					0	0	0	0
Spesa12					1	0	0	0
Spesa13					0	0	0	0
Spesa14					0	0	1	0
Spesa15					0	1	0	0
Spesa16					0	0	0	0
Spesa17					1	0	0	0
Spesa18					0	0	0	1

mentre nel secondo foglio ho una tabella da riempire del tipo

		Q1		Q2		Q3		Q4
Nome della spesa

Vorrei che sotto le colonne Q1-Q2-Q3-Q4 vengano riportati i nomi delle spese (Spesa1,Spesa2,...) a seconda se sia presente o meno il valore 1 nella tabella precedente.

Premetto che sono un principiante con le macro.

Grazie Mille in anticipo!! :)

Answer 1

Ciao Stephan88FF,

mi servirebbe un aiuto per creare una macro che mi riempia alcune colonne del foglio 2  a seconda dei valori riportati nel foglio 1. Mi spiego meglio, nel foglio 1 ho una tabella del tipo

          

Vorrei che sotto le colonne Q1-Q2-Q3-Q4 vengano riportati i nomi delle spese (Spesa1,Spesa2,...) a seconda se sia presente o meno il valore 1 nella tabella precedente.

Premetto che sono un principiante con le macro.

Per una soluzione VBA, prova qualcosa del genere:

• Alt+F11 per aprire l'editor di VBA
• Alt+IM per inserire un nuovo modulo di codice
• Nel nuovo modulo vuoto, incolla il seguente codice:

'=========>>

Option Explicit

'--------->>

Public Sub Tester()

    Dim WB As Workbook

    Dim srcSH As Worksheet, destSH As Worksheet

    Dim srcRng As Range, destRng As Range

    Dim arrIn As Variant, arrOut As Variant

    Dim LRow As Long

    Dim i As Long, j As Long

    Dim iCtr As Long, jCtr As Long, iCols As Long

    Dim UB As Long, UB2 As Long

    Const sFoglioSorgente As String = "Foglio1"            '<<=== Modifica

    Const sFoglioDestinazione As String = "Foglio2"     '<<=== Modifica

    Const sColonneSorgente As String = "A:I"                 '<<=== Modifica

    Const sPrimaColonnaDest As String = "C"                  '<<=== Modifica

    Set WB = ThisWorkbook

    With WB

        Set srcSH = .Sheets(sFoglioSorgente)

        Set destSH = .Sheets(sFoglioDestinazione)

    End With

    With srcSH

        iCols = .Columns(sColonneSorgente).Columns.Count

        LRow = LastRow(srcSH, .Columns("A:A"))

        Set srcRng = .Range("A1:A" & LRow).Resize(, iCols)

    End With

    Set destRng = destSH.Cells(2, sPrimaColonnaDest)

    arrIn = srcRng.Value

    UB = UBound(arrIn)

    UB2 = UBound(arrIn, 2)

    ReDim arrOut(1 To UB, 1 To 1)

    For i = UB2 - 3 To UB2

        iCtr = iCtr + 1

        For j = 1 To UB

            If arrIn(j, i) = 1 Then

                jCtr = jCtr + 1

                arrOut(jCtr, 1) = arrIn(j, 1)

            End If

        Next j

        destRng.Resize(jCtr).Offset(, (iCtr - 1) * 2).Value = arrOut

          jCtr = 0

        ReDim arrOut(1 To UB, 1 To 1)

    Next i

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range, _

                        Optional minRow As Long = 1, _

                        Optional sPassword As String)

    Dim bProtected As Boolean

    With SH

        If Rng Is Nothing Then

            Set Rng = .Cells

        End If

        bProtected = .ProtectContents = True

        If bProtected Then

            .Unprotect Password:=sPassword

        End If

    End With

    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

    If LastRow < minRow Then

        LastRow = minRow

    End If

    If bProtected Then

        SH.Protect Password:=sPassword, _

                   UserInterfaceOnly:=True

    End If

End Function

'<<========= 

• Alt+Q per chiudere l'editor di VBA e tornare a Excel
• Salva il file con l’estensione xlsm
• Alt+F8 per aprire  la finestra di gestione delle macro
• Seleziona Tester
• Esegui

Potresti scaricare il mio file di prova Stephan20180317.xlsm

===

Regards,

Norman