Unisci celle ad una condizione

Hai un problema con Excel?

Nuova discussione

Unisci celle ad una condizione
di teo842005 (utente non iscritto) data: 23/07/2014 11:29:34
Ciao avrei necessità di un aiuto x una macro semplicissima. Unione e sottolineatura di celle ad una determinata condizione. Mi potete aiutare gentilmente? Grazie mille.

di Grograman (utente non iscritto) data: 23/07/2014 11:34:15

if condizione then
    With tuorange
      .Merge
      .Font.Underline = xlUnderlineStyleSingle
    End With
end if

Unisci celle ad una condizione
di teo842005 (utente non iscritto) data: 23/07/2014 11:59:47
Hai una mail dove posso mandarti il file? Grazie ... sono imbranatissimo
Unisci celle ad una condizione
di teo842005 (utente non iscritto) data: 23/07/2014 12:10:04
Posso inviarvi tramite mail il file? Così mi aiutate se potete? Grazieee
di lepat (utente non iscritto) data: 23/07/2014 12:36:36
sulla destra della finestra in cui leggi le risposte c'è un pulsante che serve proprio per allegare i file
Unisci celle ad una condizione
di teo842005 (utente non iscritto) data: 23/07/2014 14:50:28
Scusami. Ho allegato l esempio del file database iniziale e del risultato che vorrei.... grazieee

di gaetanopr data: 23/07/2014 22:57:10
Ciao, però due righe di spiegazioni potevi metterle....
Per le date non usare il punto come separatore

Option Explicit
Sub Settimane()
Dim Sh As Worksheet, Lr As Long, Lr1 As Long
Dim i As Long, x As Long, n As Long, SetNum As Integer
Dim Setm(), DataIn As Long, DataFin As Long, LastCol As Long
Dim GiornoIn As Integer, GiornoFin As Integer
Dim MeseIn As Integer, MeseFin As Integer
Dim SetIn As Integer, SetFin As Integer
Set Sh = Worksheets("Rr")
Lr = Sh.Cells(Rows.Count, 2).End(xlUp).Row
Lr1 = Sh.Cells(Rows.Count, 4).End(xlUp).Row
If Lr1 < 14 Then Lr1 = 14
LastCol = Sh.Cells(14, Columns.Count).End(xlToLeft).Column
Setm = Array(SetIn, SetFin)
With Sh.Range(Cells(15, 4), Cells(Lr1 + 1, LastCol))
    .ClearContents
    .UnMerge
    .Borders(xlEdgeLeft).LineStyle = xlNone
    .Borders(xlEdgeTop).LineStyle = xlNone
    .Borders(xlEdgeBottom).LineStyle = xlNone
    .Borders(xlEdgeRight).LineStyle = xlNone
    .Borders(xlInsideVertical).LineStyle = xlNone
    .Interior.Color = xlNone
End With
Lr1 = 14
   For i = 4 To Lr
      If IsDate(Sh.Cells(i, 4).Value) And IsDate(Sh.Cells(i, 5).Value) Then
         DataIn = Sh.Cells(i, 4).Value
         DataFin = Sh.Cells(i, 5).Value
         Setm(0) = WorksheetFunction.WeekNum(DataIn, 2)
         Setm(1) = WorksheetFunction.WeekNum(DataFin, 2)
         If Setm(0) <= Setm(1) Then
           For x = 0 To 1
            For n = 6 To LastCol
              SetNum = Val(Right(Sh.Cells(14, n).Value, Len(Sh.Cells(14, n).Value) - 2))
              If SetNum = Setm(x) Then
                 Setm(x) = n
                 Exit For
              End If
            Next n
           Next x
           Lr1 = Lr1 + 1
           With Sh.Range(Cells(Lr1, 4), Cells(Lr1, LastCol))
                .Borders(xlEdgeTop).LineStyle = xlContinuous
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
                .Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Borders(xlEdgeRight).LineStyle = xlContinuous
                .Borders(xlInsideVertical).LineStyle = xlContinuous
           End With
           Sh.Cells(Lr1, 4).Value = Sh.Cells(i, 3).Value
           Sh.Cells(Lr1, 5).Value = Sh.Cells(i, 2).Value
           Sh.Range(Cells(Lr1, Setm(0)), Cells(Lr1, Setm(1))).Merge
           Sh.Range(Cells(Lr1, Setm(0)), Cells(Lr1, Setm(1))).Interior.Color = RGB(255, 155, 102)
           GiornoIn = Day(DataIn): MeseIn = Month(DataIn)
           GiornoFin = Day(DataFin): MeseFin = Month(DataFin)
           Sh.Cells(Lr1, Setm(0)).Value = GiornoIn & "/" & MeseIn & " - " & GiornoFin & "/" & MeseFin
         End If
      End If
   Next i
    
Set Sh = Nothing
End Sub

di Grograman data: 24/07/2014 09:08:33
@ Gateano: Giusto per far vedere come i bordi possono essere aggiunti/tolti tutti contemporaneamente visto che spesso sfugge questa opportunità

With Sh.Range(Cells(15, 4), Cells(Lr1 + 1, LastCol))
    .ClearContents
    .UnMerge
    .Borders.LineStyle = xlNone
    .Interior.Color = xlNone
End With


         With Sh.Range(Cells(Lr1, 4), Cells(Lr1, LastCol))
           .Borders.LineStyle = xlContinuous
         End With

di Gaetanopr (utente non iscritto) data: 24/07/2014 12:58:31
Grazie per la dritta Grograman
in questo modo nel secondo caso possiamo pure evitare l'uso di With
di gaetanopr data: 24/07/2014 14:13:40
Ho un pò rivisto la macro e aggiunto 3 msgbox, per ulteriori controlli ed avvisi in merito all'esattezza delle date inserite.
1: data finale inferiore a quella iniziale
2: settimana non presente nel calendario settimane
3: data mancante o non corretta nel database iniziale

Allego il file settimane

di gaetanopr data: 24/07/2014 14:15:55
la nuova macro

Option Explicit
Sub Settimane()
Dim Sh As Worksheet, Lr As Long, Lr1 As Long
Dim i As Long, x As Long, n As Long, SetNum As Integer
Dim Setm(), DataIn As Long, DataFin As Long, LastCol As Long
Dim GiornoIn As Integer, GiornoFin As Integer
Dim MeseIn As Integer, MeseFin As Integer, Trovato As Boolean
Dim SetIn As Integer, SetFin As Integer
Set Sh = Worksheets("Rr")
Lr = Sh.Cells(Rows.Count, 2).End(xlUp).Row
Lr1 = Sh.Cells(Rows.Count, 4).End(xlUp).Row
If Lr1 < 14 Then Lr1 = 14
LastCol = Sh.Cells(14, Columns.Count).End(xlToLeft).Column
Setm = Array(SetIn, SetFin)
With Sh.Range(Cells(15, 4), Cells(Lr1 + 1, LastCol))
    .ClearContents
    .UnMerge
    .Borders.LineStyle = xlNone
    .Interior.Color = xlNone
End With

Lr1 = 14

   For i = 4 To Lr
      If IsDate(Sh.Cells(i, 4).Value) And IsDate(Sh.Cells(i, 5).Value) Then
         DataIn = Sh.Cells(i, 4).Value
         DataFin = Sh.Cells(i, 5).Value
         Setm(0) = WorksheetFunction.WeekNum(DataIn, 2)
         Setm(1) = WorksheetFunction.WeekNum(DataFin, 2)
         If Setm(0) <= Setm(1) Then
           For x = 0 To 1
            Trovato = False
            For n = 6 To LastCol
              SetNum = Val(Right(Sh.Cells(14, n).Value, Len(Sh.Cells(14, n).Value) - 2))
              If SetNum = Setm(x) Then
                 Setm(x) = n
                 Trovato = True
                 Exit For
              End If
            Next n
           Next x
           If Trovato = False Then
              MsgBox "Settimana per la categoria " & Sh.Cells(i, 3).Value & " non trovata"
           Else
              Lr1 = Lr1 + 1
              Sh.Range(Cells(Lr1, 4), Cells(Lr1, LastCol)).Borders.LineStyle = xlContinuous
              Sh.Cells(Lr1, 4).Value = Sh.Cells(i, 3).Value
              Sh.Cells(Lr1, 5).Value = Sh.Cells(i, 2).Value
              Sh.Range(Cells(Lr1, Setm(0)), Cells(Lr1, Setm(1))).Merge
              Sh.Range(Cells(Lr1, Setm(0)), Cells(Lr1, Setm(1))).Interior.Color = RGB(255, 155, 102)
              GiornoIn = Day(DataIn): MeseIn = Month(DataIn)
              GiornoFin = Day(DataFin): MeseFin = Month(DataFin)
              Sh.Cells(Lr1, Setm(0)).Value = GiornoIn & "/" & MeseIn & " - " & GiornoFin & "/" & MeseFin
          End If
         Else
            MsgBox "Data Finale inferiore a data Iniziale categoria " & Sh.Cells(i, 3).Value
         End If
      Else
         MsgBox "Controllare la validità o la presenza delle date per la categoria " & Sh.Cells(i, 3).Value
      End If
   Next i
    
Set Sh = Nothing
End Sub

di gaetanopr data: 25/07/2014 07:51:24
Ho effettuato una modifica alla macro in quanto la verifica sulla data finale inferiore a quella iniziale in effetti avveniva sul numero della settimana delle due date, quindi nel caso di una data finale inferiore a quella iniziale ma rientrante nella stessa settimana l'anomalia non sarebbe stata segnalata dalla macro.
es: data inizio 12/07/14 settimana 28, data fine 11/07/14 settimana 28

Option Explicit
Sub Settimane()
Dim Sh As Worksheet, Lr As Long, Lr1 As Long
Dim i As Long, x As Long, n As Long, SetNum As Integer
Dim Setm(), DataIn As Long, DataFin As Long, LastCol As Long
Dim GiornoIn As Integer, GiornoFin As Integer
Dim MeseIn As Integer, MeseFin As Integer, Trovato As Boolean
Dim SetIn As Integer, SetFin As Integer
Set Sh = Worksheets("Rr")
Lr = Sh.Cells(Rows.Count, 2).End(xlUp).Row
Lr1 = Sh.Cells(Rows.Count, 4).End(xlUp).Row
If Lr1 < 14 Then Lr1 = 14
LastCol = Sh.Cells(14, Columns.Count).End(xlToLeft).Column
Setm = Array(SetIn, SetFin)
With Sh.Range(Cells(15, 4), Cells(Lr1 + 1, LastCol))
    .ClearContents
    .UnMerge
    .Borders.LineStyle = xlNone
    .Interior.Color = xlNone
End With

Lr1 = 14

   For i = 4 To Lr
      If IsDate(Sh.Cells(i, 4).Value) And IsDate(Sh.Cells(i, 5).Value) Then
         If Sh.Cells(i, 4).Value <= Sh.Cells(i, 5).Value Then
         DataIn = Sh.Cells(i, 4).Value
         DataFin = Sh.Cells(i, 5).Value
         Setm(0) = WorksheetFunction.WeekNum(DataIn, 2)
         Setm(1) = WorksheetFunction.WeekNum(DataFin, 2)
           For x = 0 To 1
            Trovato = False
            For n = 6 To LastCol
              SetNum = Val(Right(Sh.Cells(14, n).Value, Len(Sh.Cells(14, n).Value) - 2))
              If SetNum = Setm(x) Then
                 Setm(x) = n
                 Trovato = True
                 Exit For
              End If
            Next n
           Next x
           If Trovato = False Then
              MsgBox "Settimana per la categoria " & Sh.Cells(i, 3).Value & " non trovata"
           Else
              Lr1 = Lr1 + 1
              Sh.Range(Cells(Lr1, 4), Cells(Lr1, LastCol)).Borders.LineStyle = xlContinuous
              Sh.Cells(Lr1, 4).Value = Sh.Cells(i, 3).Value
              Sh.Cells(Lr1, 5).Value = Sh.Cells(i, 2).Value
              Sh.Range(Cells(Lr1, Setm(0)), Cells(Lr1, Setm(1))).Merge
              Sh.Range(Cells(Lr1, Setm(0)), Cells(Lr1, Setm(1))).Interior.Color = RGB(255, 155, 102)
              GiornoIn = Day(DataIn): MeseIn = Month(DataIn)
              GiornoFin = Day(DataFin): MeseFin = Month(DataFin)
              Sh.Cells(Lr1, Setm(0)).Value = GiornoIn & "/" & MeseIn & " - " & GiornoFin & "/" & MeseFin
          End If
         Else
            MsgBox "Data Finale inferiore a data Iniziale categoria " & Sh.Cells(i, 3).Value
         End If
      Else
         MsgBox "Controllare la validità o la presenza delle date per la categoria " & Sh.Cells(i, 3).Value
      End If
   Next i
    
Set Sh = Nothing
End Sub

Vuoi Approfondire?