回答編集履歴
2
追記
test
CHANGED
|
@@ -181,3 +181,79 @@
|
|
|
181
181
|
End Function
|
|
182
182
|
|
|
183
183
|
```
|
|
184
|
+
|
|
185
|
+
|
|
186
|
+
|
|
187
|
+
オートフィルターでやってみました。
|
|
188
|
+
|
|
189
|
+
```ExcelVBA
|
|
190
|
+
|
|
191
|
+
Sub SetTableShaping(ByRef ws As Worksheet)
|
|
192
|
+
|
|
193
|
+
Dim rngfromat As Range
|
|
194
|
+
|
|
195
|
+
Dim rngTable As Range
|
|
196
|
+
|
|
197
|
+
Dim r As Range
|
|
198
|
+
|
|
199
|
+
|
|
200
|
+
|
|
201
|
+
With ws
|
|
202
|
+
|
|
203
|
+
Set rngfromat = .Range("A1:AH3")
|
|
204
|
+
|
|
205
|
+
Set rngTable = .Range(.Range("A7"), .Cells(.Rows.Count, "A").End(xlUp)) _
|
|
206
|
+
|
|
207
|
+
.Resize(, rngfromat.Columns.Count)
|
|
208
|
+
|
|
209
|
+
End With
|
|
210
|
+
|
|
211
|
+
|
|
212
|
+
|
|
213
|
+
ws.Outline.ShowLevels ColumnLevels:=3
|
|
214
|
+
|
|
215
|
+
For Each r In rngfromat.Rows
|
|
216
|
+
|
|
217
|
+
Copy2Format r, rngTable
|
|
218
|
+
|
|
219
|
+
Next
|
|
220
|
+
|
|
221
|
+
ws.Outline.ShowLevels ColumnLevels:=1
|
|
222
|
+
|
|
223
|
+
End Sub
|
|
224
|
+
|
|
225
|
+
|
|
226
|
+
|
|
227
|
+
Private Sub Copy2Format(ByRef prngformat As Range, ByRef prngTable As Range)
|
|
228
|
+
|
|
229
|
+
With prngTable
|
|
230
|
+
|
|
231
|
+
.AutoFilter 1, prngformat.Cells(1).Value
|
|
232
|
+
|
|
233
|
+
|
|
234
|
+
|
|
235
|
+
If .Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
|
|
236
|
+
|
|
237
|
+
prngformat.Copy
|
|
238
|
+
|
|
239
|
+
Intersect(.Cells, .Offset(1)).PasteSpecial xlPasteFormats
|
|
240
|
+
|
|
241
|
+
End With
|
|
242
|
+
|
|
243
|
+
|
|
244
|
+
|
|
245
|
+
.AutoFilter
|
|
246
|
+
|
|
247
|
+
End With
|
|
248
|
+
|
|
249
|
+
End Sub
|
|
250
|
+
|
|
251
|
+
```
|
|
252
|
+
|
|
253
|
+
小計行と合計行に色を付けるのがテーマなら、
|
|
254
|
+
|
|
255
|
+
ABCをあえて入力しなくても、
|
|
256
|
+
|
|
257
|
+
他のやり方もありそうですが、
|
|
258
|
+
|
|
259
|
+
もう、おなかいっぱいでしょうね。
|
1
追記
test
CHANGED
|
@@ -91,3 +91,93 @@
|
|
|
91
91
|
End Function
|
|
92
92
|
|
|
93
93
|
```
|
|
94
|
+
|
|
95
|
+
|
|
96
|
+
|
|
97
|
+
修正しました。
|
|
98
|
+
|
|
99
|
+
```ExcelVBA
|
|
100
|
+
|
|
101
|
+
Option Explicit
|
|
102
|
+
|
|
103
|
+
|
|
104
|
+
|
|
105
|
+
Sub test()
|
|
106
|
+
|
|
107
|
+
Dim rngFormat As Range
|
|
108
|
+
|
|
109
|
+
Dim rngData As Range
|
|
110
|
+
|
|
111
|
+
|
|
112
|
+
|
|
113
|
+
With Worksheets(1)
|
|
114
|
+
|
|
115
|
+
Set rngFormat = .Range("A1").CurrentRegion.Resize(, 200)
|
|
116
|
+
|
|
117
|
+
Set rngData = .Range("A7").CurrentRegion
|
|
118
|
+
|
|
119
|
+
End With
|
|
120
|
+
|
|
121
|
+
|
|
122
|
+
|
|
123
|
+
CopyFormat rngFormat, rngData
|
|
124
|
+
|
|
125
|
+
End Sub
|
|
126
|
+
|
|
127
|
+
|
|
128
|
+
|
|
129
|
+
Function CopyFormat(ByRef rngFormat As Range, _
|
|
130
|
+
|
|
131
|
+
ByRef rngData As Range) As Boolean
|
|
132
|
+
|
|
133
|
+
Dim r As Range
|
|
134
|
+
|
|
135
|
+
Dim sKey As String
|
|
136
|
+
|
|
137
|
+
|
|
138
|
+
|
|
139
|
+
CopyFormat = True
|
|
140
|
+
|
|
141
|
+
|
|
142
|
+
|
|
143
|
+
For Each r In rngFormat.Rows
|
|
144
|
+
|
|
145
|
+
sKey = r.Cells(1).Value
|
|
146
|
+
|
|
147
|
+
|
|
148
|
+
|
|
149
|
+
With rngData.Columns(1)
|
|
150
|
+
|
|
151
|
+
.Replace sKey, ""
|
|
152
|
+
|
|
153
|
+
r.Copy
|
|
154
|
+
|
|
155
|
+
On Error GoTo ErrHandler
|
|
156
|
+
|
|
157
|
+
With .SpecialCells(xlCellTypeBlanks)
|
|
158
|
+
|
|
159
|
+
Intersect(.EntireRow, rngFormat.EntireColumn).PasteSpecial xlPasteFormats
|
|
160
|
+
|
|
161
|
+
.Value = sKey
|
|
162
|
+
|
|
163
|
+
End With
|
|
164
|
+
|
|
165
|
+
On Error GoTo 0
|
|
166
|
+
|
|
167
|
+
End With
|
|
168
|
+
|
|
169
|
+
Next
|
|
170
|
+
|
|
171
|
+
Exit Function
|
|
172
|
+
|
|
173
|
+
|
|
174
|
+
|
|
175
|
+
ErrHandler:
|
|
176
|
+
|
|
177
|
+
CopyFormat = False
|
|
178
|
+
|
|
179
|
+
Resume Next
|
|
180
|
+
|
|
181
|
+
End Function
|
|
182
|
+
|
|
183
|
+
```
|