Scal i wyśrodkuj? – dwie kolumny VBA

[Mariusz19J20]

Witam
Pracuje nad małym projektem i potrzebuje waszej pomocy. Chciałbym móc grupować zamówienia w oparciu o kategorie w kolumnie K przy użyciu filtra. Czyli jeżeli ktoś zamówił tylko owoce to chce widzieć zamówienia tylko na owoce. Oczywiście zamówienie może zawierać wszystkie kategorie i tu zaczyna się problem z filtrowaniem zamówień, gdyż pokazuje on również kategorie z mieszanego zamówienia. Czy rozwiązaniem jest scalanie komórek?

Jeżeli tak to jak napisać makro, aby scalić te komórki w dwóch różnych kolumnach tak aby odpowiadały zamówieniu.

Obecnie korzystam tego kodu i poniższym przykładzie makro scala komórki z kolumny B i nie może być użyte w kolumnie K gdyż sąsiadujące komórki mogę być tej samej kategorii ale z innego zamówienia.

Sub MergeSimilarCells()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Set myRange = Range("B2:B448")
CheckAgain:
    For Each cell In myRange
        If cell.Value = cell.Offset(1, 0).Value And Not IsEmpty(cell) Then
            Range(cell, cell.Offset(1, 0)).Merge
            cell.VerticalAlignment = xlCenter
            GoTo CheckAgain
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Tak aby wyglądało to mniej więcej tak :

Dziękuje
Mariusz

 

[sandy666]

 

[Dossfm0q]

See video

 

[sandy666]

Do you think your video will fix code in my module1 ?

 

[Mariusz19J20]

Dossfm0q thank you very much for your code its working perfectly. Probably you know that but if not so maybe it is worth mentioning as a curiosity that code is working until cells in the range does not contain #N/A. if does contain then error message pop up. and range is merge to this cells only. Thanks

 

[Dossfm0q]

Good Day
It is very nice to feed back, I am sorry for not being able to solve your problem because I did not find any problem from my side, and I thank you for the clarification with clear and good words.


try to ignore Err if this dose not interrupt your project
On Error Resume Next
the code here
On Error GoTo 0

 

[Dossfm0q]

please check below

Private Sub Worksheet_Change(ByVal Target As Range)

Dim UOR As Range, UOMR As Range, DOR As Range
Application.EnableEvents = False
Application.DisplayAlerts = False

With Target
On Error Resume Next
 Set UOR = .Offset(IIf(.Row > 1, -1, 0), 0)
 Set UOMR = UOR.MergeArea.Cells(1, 1)
 Set DOR = .Offset(1, 0)
 If .Column = 2 Then
            If ((.Value = UOR.Value Or .Value = UOMR.Value) And .Value = DOR.Value And DOR.Value <> "") Then
            If IsError(.Value) = False And IsError(UOR.Value) = False And IsError(UOMR.Value) = False And IsError(DOR.Value) = False Then
                With UOR.Resize(3, 1)
                .Merge
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                End With
            Else
            MsgBox "can not merge cell { " & .Address(False, False) & ", " & UOR.Address(False, False) & " or " & DOR.Address(False, False) & " } May cell to be merge has Error" & vbNewLine & "Please fix error the try again"
            End If
            ElseIf (.Value = UOR.Value Or .Value = UOMR.Value) And .Value <> DOR.Value Then
                With UOR.Resize(IIf(.Row > 1, 2, 1), 1)
                .Merge
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                End With
            ElseIf .Value <> UOR.Value And .Value = DOR.Value And IsError(UOR.Value) = False And IsError(DOR.Value) = False Then
                .Resize(2, 1).Merge
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
            End If
            
 ElseIf .Column = 11 Then
        If .Offset(0, -9).MergeArea.Cells(1, 1).Address = UOR.Offset(0, -9).MergeArea.Cells(1, 1).Address Or .Offset(0, -9).MergeArea.Cells(1, 1).Address = DOR.Offset(0, -9).MergeArea.Cells(1, 1).Address Then
                If ((.Value = UOR.Value Or .Value = UOMR.Value) And .Value = DOR.Value And DOR.Value <> "") Then
                If IsError(.Value) = False And IsError(UOR.Value) = False And IsError(UOMR.Value) = False And IsError(DOR.Value) = False Then
                    With UOR.Resize(3, 1)
                    .Merge
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    End With
                Else
                MsgBox "can not merge cell { " & .Address(False, False) & ", " & UOR.Address(False, False) & " or " & DOR.Address(False, False) & " } May cell to be merge has Error" & vbNewLine & "Please fix error the try again"
                End If
                ElseIf (.Value = UOR.Value Or .Value = UOMR.Value) And .Value <> DOR.Value Then
                    With UOR.Resize(IIf(.Row > 1, 2, 1), 1)
                    .Merge
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    End With
                ElseIf .Value <> UOR.Value And .Value = DOR.Value And IsError(UOR.Value) = False And IsError(DOR.Value) = False Then
                    .Resize(2, 1).Merge
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                End If
        End If
 End If
On Error GoTo 0
End With
Application.DisplayAlerts = True
Application.EnableEvents = True


End Sub