Scal i wyśrodkuj? – dwie kolumny VBA

M

Mariusz19J20

New Member
Joined
Sep 6, 2020
Messages
5
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
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.


VBA Code: 
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 :

Capture.JPG


Dziękuje
Mariusz
 

Attachments

  • rr.jpg
    rr.jpg
    38.4 KB · Views: 25

Excel Facts

Is there a shortcut key for strikethrough?
Ctrl+S is used for Save. Ctrl+5 is used for Strikethrough. Why Ctrl+5? When you use hashmarks to count |||| is 4, strike through to mean 5.
Sort by date Sort by votes
test 1.xlsm
ABCDEFGHIJKLMN
1DateOrder noOrder ReferenceSKUDescriptionSales QtySales ValueEx VAT valueCSGCINKATEGORIALOCno of lineshelper colum for condition for
62 September 2020631363MX01127288127GGGG1XXNoksiążkiWWW510
92 September 2020631371MX01127608130AAAA1XXNoplakatyWWW821
102 September 2020MX01127608131CCCC1XXNoplakatyWWW921
112 September 2020631373MX01127463132BBBB1XXNoowoceWWW1010
162 September 2020631394MX01128447137AAAA2XXNoowoceWWW1511
172 September 2020631397MX01128522138CCCC1XXNoowoceWWW1630
182 September 2020MX01128522139BBBB1XXNoksiążkiWWW1730
192 September 2020MX01128522140XXXX1XXNoowoceWWW1830
202 September 2020631399MX01128565141GGGG1XXNoplakatyWWW1921
212 September 2020MX01128565142TTTTTTT2XXNoowoceWWW2021
222 September 2020631401MX01128374143HHHHHH4XXNoowoceWWW2160
232 September 2020MX01128374144AAAA1XXNoowoceWWW2260
242 September 2020MX01128374145CCCC1XXNoowoceWWW2360
252 September 2020MX01128374146BBBB1XXNoowoceWWW2460
262 September 2020MX01128374147XXXX1XXNoowoceWWW2560
272 September 2020MX01128374148GGGG1XXNoowoceWWW2660
282 September 2020631405MX01128636149TTTTTTT1XXNoksiążkiWWW2771
292 September 2020MX01128636150HHHHHH1XXNoksiążkiWWW2871
302 September 2020MX01128636151AAAA1XXNoksiążkiWWW2971
312 September 2020MX01128636152CCCC1XXNoksiążkiWWW3071
322 September 2020MX01128636153BBBB1XXNoksiążkiWWW3171
332 September 2020MX01128636154XXXX1XXNoksiążkiWWW3271
342 September 2020MX01128636155GGGG1XXNoksiążkiWWW3371
412 September 2020631413MX01128727162GGGG1XXNoowoceWWW4010
422 September 2020631414MX01128812163TTTTTTT1XXNoowoceWWW4111
432 September 2020631415MX01128739164HHHHHH1XXNoowoceWWW4220
442 September 2020MX01128739165AAAA1XXNoplakatyWWW4320
NEW all orders on batch
Cell Formulas
RangeFormula
M6,M9:M11,M16:M34,M41:M44M6=COUNTIF($C$2:C:C,C6)
N6,N9:N11,N16:N34,N41:N44N6=MOD(IF(ROW()=2,0,IF(C6=C5,N5, N5+1)), 2)
Cells with Conditional Formatting
CellConditionCell FormatStop If True
B2:B448Expression=$N2=1textNO
A2:A448,C2:N448Expression=$N2=1textNO
 
Upvote 0
like this?

DateOrder noSKUDescriptionSales QtySales ValueEx VAT valueCSOrder ReferenceKATEGORIALOC
02/09/2020631363127GGGG1XXNoMX01127288książkiWWW5
02/09/2020631371130AAAA1XXNoMX01127608plakaty plakatyWWW8 WWW9
02/09/2020131CCCC1XXNoMX01127608plakaty plakatyWWW8 WWW9
02/09/2020631373132BBBB1XXNoMX01127463owoceWWW10
02/09/2020631394137AAAA2XXNoMX01128447owoceWWW15
02/09/2020631397138CCCC1XXNoMX01128522owoce książki owoceWWW16 WWW17 WWW18
02/09/2020139BBBB1XXNoMX01128522owoce książki owoceWWW16 WWW17 WWW18
02/09/2020140XXXX1XXNoMX01128522owoce książki owoceWWW16 WWW17 WWW18
02/09/2020631399141GGGG1XXNoMX01128565plakaty owoceWWW19 WWW20
02/09/2020142TTTTTTT2XXNoMX01128565plakaty owoceWWW19 WWW20
02/09/2020631401143HHHHHH4XXNoMX01128374owoce owoce owoce owoce owoce owoceWWW21 WWW22 WWW23 WWW24 WWW25 WWW26
02/09/2020144AAAA1XXNoMX01128374owoce owoce owoce owoce owoce owoceWWW21 WWW22 WWW23 WWW24 WWW25 WWW26
02/09/2020145CCCC1XXNoMX01128374owoce owoce owoce owoce owoce owoceWWW21 WWW22 WWW23 WWW24 WWW25 WWW26
02/09/2020146BBBB1XXNoMX01128374owoce owoce owoce owoce owoce owoceWWW21 WWW22 WWW23 WWW24 WWW25 WWW26
02/09/2020147XXXX1XXNoMX01128374owoce owoce owoce owoce owoce owoceWWW21 WWW22 WWW23 WWW24 WWW25 WWW26
02/09/2020148GGGG1XXNoMX01128374owoce owoce owoce owoce owoce owoceWWW21 WWW22 WWW23 WWW24 WWW25 WWW26
02/09/2020631405149TTTTTTT1XXNoMX01128636książki książki książki książki książki książki książkiWWW27 WWW28 WWW29 WWW30 WWW31 WWW32 WWW33
02/09/2020150HHHHHH1XXNoMX01128636książki książki książki książki książki książki książkiWWW27 WWW28 WWW29 WWW30 WWW31 WWW32 WWW33
02/09/2020151AAAA1XXNoMX01128636książki książki książki książki książki książki książkiWWW27 WWW28 WWW29 WWW30 WWW31 WWW32 WWW33
02/09/2020152CCCC1XXNoMX01128636książki książki książki książki książki książki książkiWWW27 WWW28 WWW29 WWW30 WWW31 WWW32 WWW33
02/09/2020153BBBB1XXNoMX01128636książki książki książki książki książki książki książkiWWW27 WWW28 WWW29 WWW30 WWW31 WWW32 WWW33
02/09/2020154XXXX1XXNoMX01128636książki książki książki książki książki książki książkiWWW27 WWW28 WWW29 WWW30 WWW31 WWW32 WWW33
02/09/2020155GGGG1XXNoMX01128636książki książki książki książki książki książki książkiWWW27 WWW28 WWW29 WWW30 WWW31 WWW32 WWW33
02/09/2020631413162GGGG1XXNoMX01128727owoceWWW40
02/09/2020631414163TTTTTTT1XXNoMX01128812owoceWWW41
02/09/2020631415164HHHHHH1XXNoMX01128739owoce plakatyWWW42 WWW43
02/09/2020165AAAA1XXNoMX01128739owoce plakatyWWW42 WWW43
 
Upvote 0
or like this

DateOrder noSKUDescriptionSales QtySales ValueEx VAT valueCSOrder ReferenceKATEGORIALOC
02/09/2020631363127GGGG1XXNoMX01127288książkiWWW5
02/09/2020631371130AAAA1XXNoMX01127608plakatyWWW8 WWW9
02/09/2020131CCCC1XXNoMX01127608plakatyWWW8 WWW9
02/09/2020631373132BBBB1XXNoMX01127463owoceWWW10
02/09/2020631394137AAAA2XXNoMX01128447owoceWWW15
02/09/2020631397138CCCC1XXNoMX01128522owoce książkiWWW16 WWW17 WWW18
02/09/2020139BBBB1XXNoMX01128522owoce książkiWWW16 WWW17 WWW18
02/09/2020140XXXX1XXNoMX01128522owoce książkiWWW16 WWW17 WWW18
02/09/2020631399141GGGG1XXNoMX01128565plakaty owoceWWW19 WWW20
02/09/2020142TTTTTTT2XXNoMX01128565plakaty owoceWWW19 WWW20
02/09/2020631401143HHHHHH4XXNoMX01128374owoceWWW21 WWW22 WWW23 WWW24 WWW25 WWW26
02/09/2020144AAAA1XXNoMX01128374owoceWWW21 WWW22 WWW23 WWW24 WWW25 WWW26
02/09/2020145CCCC1XXNoMX01128374owoceWWW21 WWW22 WWW23 WWW24 WWW25 WWW26
02/09/2020146BBBB1XXNoMX01128374owoceWWW21 WWW22 WWW23 WWW24 WWW25 WWW26
02/09/2020147XXXX1XXNoMX01128374owoceWWW21 WWW22 WWW23 WWW24 WWW25 WWW26
02/09/2020148GGGG1XXNoMX01128374owoceWWW21 WWW22 WWW23 WWW24 WWW25 WWW26
02/09/2020631405149TTTTTTT1XXNoMX01128636książkiWWW27 WWW28 WWW29 WWW30 WWW31 WWW32 WWW33
02/09/2020150HHHHHH1XXNoMX01128636książkiWWW27 WWW28 WWW29 WWW30 WWW31 WWW32 WWW33
02/09/2020151AAAA1XXNoMX01128636książkiWWW27 WWW28 WWW29 WWW30 WWW31 WWW32 WWW33
02/09/2020152CCCC1XXNoMX01128636książkiWWW27 WWW28 WWW29 WWW30 WWW31 WWW32 WWW33
02/09/2020153BBBB1XXNoMX01128636książkiWWW27 WWW28 WWW29 WWW30 WWW31 WWW32 WWW33
02/09/2020154XXXX1XXNoMX01128636książkiWWW27 WWW28 WWW29 WWW30 WWW31 WWW32 WWW33
02/09/2020155GGGG1XXNoMX01128636książkiWWW27 WWW28 WWW29 WWW30 WWW31 WWW32 WWW33
02/09/2020631413162GGGG1XXNoMX01128727owoceWWW40
02/09/2020631414163TTTTTTT1XXNoMX01128812owoceWWW41
02/09/2020631415164HHHHHH1XXNoMX01128739owoce plakatyWWW42 WWW43
02/09/2020165AAAA1XXNoMX01128739owoce plakatyWWW42 WWW43
 
Upvote 0
correction for KATEGORIA column
DateOrder noSKUDescriptionSales QtySales ValueEx VAT valueCSKATEGORIALOC
02/09/2020631363127GGGG1XXNoksiążkiWWW5
02/09/2020631371130AAAA1XXNoplakatyWWW8 WWW9
02/09/2020131CCCC1XXNoplakatyWWW8 WWW9
02/09/2020631373132BBBB1XXNoowoceWWW10 WWW15 WWW16
02/09/2020631394137AAAA2XXNoowoceWWW10 WWW15 WWW16
02/09/2020631397138CCCC1XXNoowoceWWW10 WWW15 WWW16
02/09/2020139BBBB1XXNoksiążkiWWW17
02/09/2020140XXXX1XXNoowoceWWW18
02/09/2020631399141GGGG1XXNoplakatyWWW19
02/09/2020142TTTTTTT2XXNoowoceWWW20 WWW21 WWW22 WWW23 WWW24 WWW25 WWW26
02/09/2020631401143HHHHHH4XXNoowoceWWW20 WWW21 WWW22 WWW23 WWW24 WWW25 WWW26
02/09/2020144AAAA1XXNoowoceWWW20 WWW21 WWW22 WWW23 WWW24 WWW25 WWW26
02/09/2020145CCCC1XXNoowoceWWW20 WWW21 WWW22 WWW23 WWW24 WWW25 WWW26
02/09/2020146BBBB1XXNoowoceWWW20 WWW21 WWW22 WWW23 WWW24 WWW25 WWW26
02/09/2020147XXXX1XXNoowoceWWW20 WWW21 WWW22 WWW23 WWW24 WWW25 WWW26
02/09/2020148GGGG1XXNoowoceWWW20 WWW21 WWW22 WWW23 WWW24 WWW25 WWW26
02/09/2020631405149TTTTTTT1XXNoksiążkiWWW27 WWW28 WWW29 WWW30 WWW31 WWW32 WWW33
02/09/2020150HHHHHH1XXNoksiążkiWWW27 WWW28 WWW29 WWW30 WWW31 WWW32 WWW33
02/09/2020151AAAA1XXNoksiążkiWWW27 WWW28 WWW29 WWW30 WWW31 WWW32 WWW33
02/09/2020152CCCC1XXNoksiążkiWWW27 WWW28 WWW29 WWW30 WWW31 WWW32 WWW33
02/09/2020153BBBB1XXNoksiążkiWWW27 WWW28 WWW29 WWW30 WWW31 WWW32 WWW33
02/09/2020154XXXX1XXNoksiążkiWWW27 WWW28 WWW29 WWW30 WWW31 WWW32 WWW33
02/09/2020155GGGG1XXNoksiążkiWWW27 WWW28 WWW29 WWW30 WWW31 WWW32 WWW33
02/09/2020631413162GGGG1XXNoowoceWWW40 WWW41 WWW42
02/09/2020631414163TTTTTTT1XXNoowoceWWW40 WWW41 WWW42
02/09/2020631415164HHHHHH1XXNoowoceWWW40 WWW41 WWW42
02/09/2020165AAAA1XXNoplakatyWWW43
 
Upvote 0
Not exactly. I'm looking something like this. please see comment in column L maybe this help to understand what I meant. Merge cells should be only in column B and K.
test 1.xlsm
ABCDEFGHIJKL
22 September 2020631361MX01127249124CCCC1XXNoowocecells k2:k4 should be Merge as is one order for 3 items from the same category (owoce)
32 September 2020MX01127249125BBBB1XXNo
42 September 2020MX01127249126XXXX1XXNo
52 September 2020631363MX01127288127GGGG1XXNoowocesinge oredr one line not a problem
62 September 2020631364MX01127359128TTTTTTT1XXNoplakatysinge oredr one line not a problem
72 September 2020631370MX01127594129HHHHHH2XXNoplakatysinge oredr one line not a problem
82 September 2020631371MX01127608130AAAA1XXNoplakatycells k8:k9 should be Merge as is one order for 2 items from the same category (plakaty)
92 September 2020MX01127608131CCCC1XXNo
102 September 2020631373MX01127463132BBBB1XXNoowocesinge oredr one line not a problem
112 September 2020631397MX01128522138CCCC1XXNoowoceand here k11 :k13 should Not to Merge as is mix basket for 3 item from different cat.
122 September 2020MX01128522139BBBB1XXNoksiążki
132 September 2020MX01128522140XXXX1XXNoowoce
143 September 2020555666W01134819141BBBB2XXNoowocemerge K14:K18 one order all item from the same category
154 September 2020W01134819142CCCC3XXNo
165 September 2020W01134819143BBBB4XXNo
176 September 2020W01134819144XXXX5XXNo
187 September 2020W01134819145BBBB6XXNo
192 September 2020631418MX01128918146XXXX1XXNoksiążkisinge oredr one line not a problem
202 September 2020631399MX01128565147GGGG1XXNoksiążkihere k20 :k21 should Not to Merge as is mix basket for 2 item form different category
212 September 2020MX01128565148TTTTTTT2XXNoowoce
NEW all orders on batch
 
Upvote 0
what about Order no in blank rows?
631394MX01128447
631397MX01128522
MX01128522
MX01128522
631399MX01128565
MX01128565
631401MX01128374
MX01128374
MX01128374
MX01128374
MX01128374
MX01128374
631405MX01128636
MX01128636
MX01128636
MX01128636
MX01128636
MX01128636
MX01128636
 
Upvote 0
I think you should post source data without merged cells/rows (no colours!) and expected result from this source
 
Upvote 0
good Day
in Worksheet Module Private Sub Worksheet_Change(ByVal Target As Range)

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Rng As Range
  Application.DisplayAlerts = False
    Application.EnableEvents = False
    For Each Rng In Range(ActiveSheet.UsedRange.Columns("B:K").Address)
        If Rng.Row > 1 And Rng <> "" Then
            If Rng.Column = 2 Then
               
                If Rng.Value = Rng.Offset(-1, 0).Value Or Rng.Value = Rng.Offset(-1, 0).MergeArea.Cells(1, 1).Value Then
                    With Rng.Offset(-1, 0).Resize(2, 1)
                      .Merge
                      .HorizontalAlignment = xlCenter
                      .VerticalAlignment = xlCenter
                      With .Interior
                          .Pattern = xlSolid
                          .Color = RGB(0, 176, 240)
                      End With
                     
                    End With
                End If
               
            ElseIf Rng.Column = 11 Then
           
                If Rng.Value = Rng.Offset(-1, 0).Value Or Rng.Value = Rng.Offset(-1, 0).MergeArea.Cells(1, 1).Value Then
                    If Cells(Rng.Row, 2).MergeArea.Cells(1, 1).Value = Cells(Rng.Row, 2).Offset(-1, 0).MergeArea.Cells(1, 1).Value Or (Cells(Rng.Row, 2).Value = Cells(Rng.Row, 2).Offset(-1, 0).Value Or Cells(Rng.Row, 2).Value = Cells(Rng.Row, 2).Offset(-1, 0).MergeArea.Cells(1, 1).Value) Then
                   
                        With Rng.Offset(-1, 0).Resize(2, 1)
                          .Merge
                          .HorizontalAlignment = xlCenter
                          .VerticalAlignment = xlCenter
                          With .Interior
                              .Pattern = xlSolid
                              .Color = RGB(0, 176, 240)
                          End With
                         
                        End With
                       
                    End If
                End If
               
            End If
        End If
    Next
    Application.EnableEvents = True
Application.DisplayAlerts = True

End Sub

or in Normal Module




Code: 
Sub MergeMyCell()

  Dim Rng As Range
  Application.DisplayAlerts = False
    For Each Rng In Range(ActiveSheet.UsedRange.Columns("B:K").Address)
        If Rng.Row > 1 And Rng <> "" Then
            If Rng.Column = 2 Then
                
                If Rng.Value = Rng.Offset(-1, 0).Value Or Rng.Value = Rng.Offset(-1, 0).MergeArea.Cells(1, 1).Value Then
                    With Rng.Offset(-1, 0).Resize(2, 1)
                      .Merge
                      .HorizontalAlignment = xlCenter
                      .VerticalAlignment = xlCenter
                      With .Interior
                          .Pattern = xlSolid
                          .Color = RGB(0, 176, 240)
                      End With
                      
                    End With
                End If
                
            ElseIf Rng.Column = 11 Then
            
                If Rng.Value = Rng.Offset(-1, 0).Value Or Rng.Value = Rng.Offset(-1, 0).MergeArea.Cells(1, 1).Value Then
                    If Cells(Rng.Row, 2).MergeArea.Cells(1, 1).Value = Cells(Rng.Row, 2).Offset(-1, 0).MergeArea.Cells(1, 1).Value Or (Cells(Rng.Row, 2).Value = Cells(Rng.Row, 2).Offset(-1, 0).Value Or Cells(Rng.Row, 2).Value = Cells(Rng.Row, 2).Offset(-1, 0).MergeArea.Cells(1, 1).Value) Then
                    
                        With Rng.Offset(-1, 0).Resize(2, 1)
                          .Merge
                          .HorizontalAlignment = xlCenter
                          .VerticalAlignment = xlCenter
                          With .Interior
                              .Pattern = xlSolid
                              .Color = RGB(0, 176, 240)
                          End With
                          
                        End With
                        
                    End If
                End If
                
            End If
        End If
    Next
Application.DisplayAlerts = True
End Sub

Module.gif
 
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,224,867
Messages
6,181,480
Members
453,046
Latest member
Excelvbaexpert

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top