Excel: How to filter data with merged cells

Private Sub CommandButton1_Click()
 
If Not ActiveSheet.FilterMode Then
   MsgBox "DEBE FILTRAR POR CLIENTE ANTES DE PROCEDER A ENVIAR LA INFORMACION AL CUADERNO DE ENTREGAS"
   Exit Sub
End If
 
    Dim wsDB As Worksheet, wsLoad As Worksheet, wbLoad As Workbook
    Dim rngLoad As Range, rngDB As Range
    Dim i As Integer, bFound As Boolean
    Dim lRowSt As Long, lRowEnd As Long
    
    Const DBname = "DATA-BASE.XLS", DBLoad = "LOAD.XLS"
    
    'save ref to Database Worksheet
    Set wsDB = ActiveSheet
    
    'test to see if LOAD is available
    bFound = False
    For i = 1 To Workbooks.Count
        If UCase(Workbooks(i).Name) = DBLoad Then
            'found
            bFound = True
            Set wbLoad = Workbooks(i)
            Exit For
        End If
    Next i
    If Not bFound Then
        MsgBox "EL LIBRO DE ENTREGAS NO ESTA ABIERTO, DEBE ABRIRLO ANTES DE REALIZAR ESTA ACCION", vbCritical, "Error"
        Exit Sub
    End If
    
    For i = 1 To wbLoad.Sheets.Count
        If wbLoad.Sheets(i).Name = wsDB.Name Then
            bFound = True
            Set wsLoad = wbLoad.Sheets(i)
            Exit For
        End If
    Next i
    If Not bFound Then
        MsgBox "Matching worksheet not found in Load. Create before continuing", vbCritical, "Error"
        Exit Sub
    End If
    
    'determoine the output area
    Set rngLoad = wsLoad.Cells(wsLoad.Rows.Count, "A").End(xlUp).Offset(1, 0)
 
      'now find the input
    lRowSt = 0: i = 1
    wsDB.Range("A11").Activate
    ActiveCell.Offset(1, 0).Activate
    Do While ActiveCell.EntireRow.Hidden = True
        'finf the first visible row
        ActiveCell.Offset(1, 0).Activate
    Loop
    If ActiveCell.Value <> "" Then
        'ie not empty
         lRowSt = ActiveCell.Row
    End If
    ActiveCell.Offset(1, 0).Activate
    Do While ActiveCell.Value <> ""
        'find the last visible row
        If ActiveCell.EntireRow.Hidden = False Then
            lRowEnd = ActiveCell.Row
        End If
        ActiveCell.Offset(1, 0).Activate
    Loop
    If lRowEnd = 0 Then lRowEnd = lRowSt
    'now we can do the copy
    wsLoad.Unprotect
    
    wsDB.Range("A" & lRowSt, "A" & lRowEnd).Copy
    rngLoad.Offset(0, 0).PasteSpecial xlPasteValues
    
    wsDB.Range("D" & lRowSt, "D" & lRowEnd).Copy
    rngLoad.Offset(0, 1).PasteSpecial xlPasteValues
    
    wsDB.Range("L" & lRowSt, "L" & lRowEnd).Copy
    rngLoad.Offset(0, 11).PasteSpecial xlPasteValues
    
    wsDB.Range("M" & lRowSt, "M" & lRowEnd).Copy
    rngLoad.Offset(0, 12).PasteSpecial xlPasteValues
    
    wsDB.Range("O" & lRowSt, "O" & lRowEnd).Copy
    rngLoad.Offset(0, 13).PasteSpecial xlPasteValues
    
    wsDB.Range("P" & lRowSt, "P" & lRowEnd).Copy
    rngLoad.Offset(0, 14).PasteSpecial xlPasteValues
    
    wsDB.Range("K" & lRowSt, "K" & lRowEnd).Copy
    rngLoad.Offset(0, 15).PasteSpecial xlPasteValues
    
    wsLoad.Activate
    ix = Selection.Rows.Count
    'now need to merge cells'
    rngLoad.Offset(0, 0).Select
    Application.DisplayAlerts = False 'turn off prompt'
    
    For iy = 2 To 11   'the columns B-K'
        wsLoad.Range(rngLoad.Cells(1, iy), rngLoad.Cells(ix, iy)).Merge (False)
    Next iy
    
    Application.DisplayAlerts = False 'turn on prompt'
    
    'now format output zone'
    iy = 18 'ie column R'
    wsLoad.Range(rngLoad.Cells(1, 1), rngLoad.Cells(ix, iy)).Select
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
       If ix = 1 Then
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
        Else
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End If
    End With
     
    rngLoad.Offset(0, 0).Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowInsertingRows:=True, AllowDeletingRows:=True, AllowFiltering:=True
    
End Sub
                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:

Private Sub CommandButton1_Click()
 
    If Not ActiveSheet.FilterMode Then
        MsgBox "DEBE FILTRAR POR CLIENTE ANTES DE PROCEDER A ENVIAR LA INFORMACION AL CUADERNO DE ENTREGAS"
        Exit Sub
    End If
 
    Dim wsDB As Worksheet, wsLoad As Worksheet, wbLoad As Workbook
    Dim rngLoad As Range, rngDB As Range
    Dim i As Integer, bFound As Boolean
    Dim lRowSt As Long, lRowEnd As Long
 
    Const DBname = "DATA-BASE.XLS", DBLoad = "LOAD.XLS"
 
    'save ref to Database Worksheet
    Set wsDB = ActiveSheet
 
    'test to see if LOAD is available
    bFound = False
    For i = 1 To Workbooks.Count
        If UCase(Workbooks(i).Name) = DBLoad Then
            'found
            bFound = True
            Set wbLoad = Workbooks(i)
            Exit For
        End If
    Next i
    If Not bFound Then
        MsgBox "EL LIBRO DE ENTREGAS NO ESTA ABIERTO, DEBE ABRIRLO ANTES DE REALIZAR ESTA ACCION", vbCritical, "Error"
        Exit Sub
    End If
 
    For i = 1 To wbLoad.Sheets.Count
        If wbLoad.Sheets(i).Name = wsDB.Name Then
            bFound = True
            Set wsLoad = wbLoad.Sheets(i)
            Exit For
        End If
    Next i
    If Not bFound Then
        MsgBox "Matching worksheet not found in Load. Create before continuing", vbCritical, "Error"
        Exit Sub
    End If
 
    'determoine the output area
    Set rngLoad = wsLoad.Cells(wsLoad.Rows.Count, "A").End(xlUp).Offset(1, 0)
 
    'now find the input
    lRowSt = 0: i = 1
    wsDB.Range("A11").Activate
    ActiveCell.Offset(1, 0).Activate
    Do While ActiveCell.EntireRow.Hidden = True
        'finf the first visible row
        ActiveCell.Offset(1, 0).Activate
    Loop
    If ActiveCell.Value <> "" Then
        'ie not empty
        lRowSt = ActiveCell.Row
    End If
    ActiveCell.Offset(1, 0).Activate
    Do While ActiveCell.Value <> ""
        'find the last visible row
        If ActiveCell.EntireRow.Hidden = False Then
            lRowEnd = ActiveCell.Row
        End If
        ActiveCell.Offset(1, 0).Activate
    Loop
    If lRowEnd = 0 Then lRowEnd = lRowSt
    'now we can do the copy
    wsLoad.Unprotect
 
    wsDB.Range("A" & lRowSt, "A" & lRowEnd).Copy
    rngLoad.Offset(0, 0).PasteSpecial xlPasteValues
 
    wsDB.Range("D" & lRowSt, "D" & lRowEnd).Copy
    rngLoad.Offset(0, 1).PasteSpecial xlPasteValues
 
    wsDB.Range("L" & lRowSt, "L" & lRowEnd).Copy
    rngLoad.Offset(0, 11).PasteSpecial xlPasteValues
 
    wsDB.Range("M" & lRowSt, "M" & lRowEnd).Copy
    rngLoad.Offset(0, 12).PasteSpecial xlPasteValues
 
    wsDB.Range("O" & lRowSt, "O" & lRowEnd).Copy
    rngLoad.Offset(0, 13).PasteSpecial xlPasteValues
 
    wsDB.Range("P" & lRowSt, "P" & lRowEnd).Copy
    rngLoad.Offset(0, 14).PasteSpecial xlPasteValues
 
    wsDB.Range("K" & lRowSt, "K" & lRowEnd).Copy
    rngLoad.Offset(0, 15).PasteSpecial xlPasteValues
 
    wsLoad.Activate
    ix = Selection.Rows.Count
    'now need to merge cells'
    rngLoad.Offset(0, 0).Select
    Application.DisplayAlerts = False    'turn off prompt'
 
 
    Dim srow As Long, lrow As Long, v As Long, c As Long
    srow = 7
    lrow = wsLoad.Cells(Cells.Rows.Count, "b").End(xlUp).Row
 
    Do Until srow > lrow
        If wsLoad.Cells(srow, "B") = wsLoad.Cells(srow + 1, "B").Value Then
            c = srow
            Do Until wsLoad.Cells(srow, "B").Value <> wsLoad.Cells(srow + 1, "B").Value
                srow = srow + 1
            Loop
            For iy = 2 To 11   'the columns B-K'
                wsLoad.Range(Cells(c, iy).Address & ":" & Cells(srow, iy).Address).Merge (False)
            Next iy
            srow = srow + 1
        Else
            srow = srow + 1
        End If
    Loop
 
    Application.DisplayAlerts = False    'turn on prompt'
 
    'now format output zone'
    iy = 18    'ie column R'
    wsLoad.Range(rngLoad.Cells(1, 1), rngLoad.Cells(ix, iy)).Select
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        If ix = 1 Then
            Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
        Else
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End If
    End With
 
    rngLoad.Offset(0, 0).Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
                      , AllowInsertingRows:=True, AllowDeletingRows:=True, AllowFiltering:=True
 
End Sub

                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:

Private Sub CommandButton1_Click()
 
    If Not ActiveSheet.FilterMode Then
        MsgBox "DEBE FILTRAR POR CLIENTE ANTES DE PROCEDER A ENVIAR LA INFORMACION AL CUADERNO DE ENTREGAS"
        Exit Sub
    End If
 
    Dim wsDB As Worksheet, wsLoad As Worksheet, wbLoad As Workbook
    Dim rngLoad As Range, rngDB As Range
    Dim i As Integer, bFound As Boolean
    Dim lRowSt As Long, lRowEnd As Long
 
    Const DBname = "DATA-BASE.XLS", DBLoad = "LOAD.XLS"
 
    'save ref to Database Worksheet
    Set wsDB = ActiveSheet
 
    'test to see if LOAD is available
    bFound = False
    For i = 1 To Workbooks.Count
        If UCase(Workbooks(i).Name) = DBLoad Then
            'found
            bFound = True
            Set wbLoad = Workbooks(i)
            Exit For
        End If
    Next i
    If Not bFound Then
        MsgBox "EL LIBRO DE ENTREGAS NO ESTA ABIERTO, DEBE ABRIRLO ANTES DE REALIZAR ESTA ACCION", vbCritical, "Error"
        Exit Sub
    End If
 
    For i = 1 To wbLoad.Sheets.Count
        If wbLoad.Sheets(i).Name = wsDB.Name Then
            bFound = True
            Set wsLoad = wbLoad.Sheets(i)
            Exit For
        End If
    Next i
    If Not bFound Then
        MsgBox "Matching worksheet not found in Load. Create before continuing", vbCritical, "Error"
        Exit Sub
    End If
 
    'determoine the output area
    Set rngLoad = wsLoad.Cells(wsLoad.Rows.Count, "A").End(xlUp).Offset(1, 0)
 
    'now find the input
    lRowSt = 0: i = 1
    wsDB.Range("A11").Activate
    ActiveCell.Offset(1, 0).Activate
    Do While ActiveCell.EntireRow.Hidden = True
        'finf the first visible row
        ActiveCell.Offset(1, 0).Activate
    Loop
    If ActiveCell.Value <> "" Then
        'ie not empty
        lRowSt = ActiveCell.Row
    End If
    ActiveCell.Offset(1, 0).Activate
    Do While ActiveCell.Value <> ""
        'find the last visible row
        If ActiveCell.EntireRow.Hidden = False Then
            lRowEnd = ActiveCell.Row
        End If
        ActiveCell.Offset(1, 0).Activate
    Loop
    If lRowEnd = 0 Then lRowEnd = lRowSt
    'now we can do the copy
    wsLoad.Unprotect
 
    wsDB.Range("A" & lRowSt, "A" & lRowEnd).Copy
    rngLoad.Offset(0, 0).PasteSpecial xlPasteValues
 
    wsDB.Range("D" & lRowSt, "D" & lRowEnd).Copy
    rngLoad.Offset(0, 1).PasteSpecial xlPasteValues
 
    wsDB.Range("L" & lRowSt, "L" & lRowEnd).Copy
    rngLoad.Offset(0, 11).PasteSpecial xlPasteValues
 
    wsDB.Range("M" & lRowSt, "M" & lRowEnd).Copy
    rngLoad.Offset(0, 12).PasteSpecial xlPasteValues
 
    wsDB.Range("O" & lRowSt, "O" & lRowEnd).Copy
    rngLoad.Offset(0, 13).PasteSpecial xlPasteValues
 
    wsDB.Range("P" & lRowSt, "P" & lRowEnd).Copy
    rngLoad.Offset(0, 14).PasteSpecial xlPasteValues
 
    wsDB.Range("K" & lRowSt, "K" & lRowEnd).Copy
    rngLoad.Offset(0, 15).PasteSpecial xlPasteValues
 
    wsLoad.Activate
    ix = Selection.Rows.Count
    'now need to merge cells'
    rngLoad.Offset(0, 0).Select
    Application.DisplayAlerts = False    'turn off prompt'
 
 
    Dim srow As Long, lrow As Long, v As Long, c As Long
    Dim response As Date
    srow = 7
    lrow = wsLoad.Cells(Cells.Rows.Count, "b").End(xlUp).Row
 
 Do Until srow > lrow
 If wsLoad.Cells(srow, "C").Value = wsLoad.Cells(srow - 1, "C").Value Then
 wsLoad.Cells(srow, "C").Value = response
 wsLoad.Cells(srow, "C").NumberFormat = "mm/dd/yy"
 srow = srow + 1
 Else
 response = Application.InputBox("Please enter Delivery date for " & wsLoad.Cells(srow, "B").Value, "Enter Date", Type:=1)
 wsLoad.Cells(srow, "C").Value = response
  wsLoad.Cells(srow, "C").NumberFormat = "mm/dd/yy"
 srow = srow + 1
 End If
 Loop
 
 
 
 
    Do Until srow > lrow
        If wsLoad.Cells(srow, "B") = wsLoad.Cells(srow + 1, "B").Value Then
            c = srow
            Do Until wsLoad.Cells(srow, "B").Value <> wsLoad.Cells(srow + 1, "B").Value
                srow = srow + 1
            Loop
            For iy = 2 To 11   'the columns B-K'
            If iy <> 3 Then wsLoad.Range(Cells(c, iy).Address & ":" & Cells(srow, iy).Address).Merge (False)
            Next iy
            srow = srow + 1
        Else
            srow = srow + 1
        End If
    Loop
 
    Application.DisplayAlerts = False    'turn on prompt'
 
    'now format output zone'
    iy = 18    'ie column R'
    wsLoad.Range(rngLoad.Cells(1, 1), rngLoad.Cells(ix, iy)).Select
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        If ix = 1 Then
            Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
        Else
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End If
    End With
 
    rngLoad.Offset(0, 0).Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
                      , AllowInsertingRows:=True, AllowDeletingRows:=True, AllowFiltering:=True
 
End Sub

                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180: