[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『色付きセルの並び替え』（超初心者）
VBA初心者です。
外部からデータを取り込んで、
外部のデータの開催日日付を本日以降と開催日未定、年間費を拾い出して
それを、指定してあるワークシートをコピーして
そこに転記する。
そして、転記したシートは、今日以降の日付順に並べるマクロを作りたいです。
外部からの転記、並び替えまでは、できたのですが、
並び替えの際に、もとのシートが偶数行ごとに背景色が塗ってあり、
並び替えの際に、背景色と一緒に並び替えを行ってしまい、
ガタガタになってしまいます。
対処法を教えていただけないでしょうか。
お願いいたします。
Sub データの取込み_Click()
Dim Sname As String
Dim Sname2 As String
Dim ws1 As Worksheet
Dim ws4 As Worksheet
Dim filePath As String
Dim wb1 As Workbook
Dim MyRNG As Range
Dim i As Long
Dim n As Long
Sname = StrConv(Format(Date, "yyyy.m"), vbWide) '*シート名を○○○○.○月へ変更*'
On Error Resume Next
Set ws4 = ThisWorkbook.Worksheets(Sname)
On Error GoTo 0
'▼該当シートの有無で処理分岐
If ws4 Is Nothing Then
ThisWorkbook.Sheets("記入用").Copy before:=ThisWorkbook.Sheets("操作画面")
Set ws4 = ThisWorkbook.Sheets("操作画面").Previous
ws4.Name = Sname
ws4.Range("F3").Font.Size = 24 'フォントを24に設定
Else '既にシートが作成されていた場合(上書想定)
ws4.Range(ws4.Cells(6, "B"), ws4.Cells(ws4.Cells(ws4.Rows.Count, "B").End(xlUp).Row, "L")).ClearContents
End If
'*デーやの取込み【テスト】のExcelを取込み*'
ChDir ThisWorkbook.Path
filePath = Application.GetOpenFilename(FileFilter:="csvファイル(*.csv),*.csv", Title:="csvファイルの選択")
If filePath = "False" Then
MsgBox "ファイルが選択されなかったので処理を中止します。"
Exit Sub
Else
Set wb1 = Workbooks.Open(filePath)
Set ws1 = wb1.Worksheets(1)
End If
Sname2 = StrConv(Format(Date, " (yyyy.m.dd)"), vbWide) '*新しく作成した、シートのＦ列３行目に ○○○○．○○．○○を記入*'
ws4.Range("F3").Value = Sname2
n = ws4.Cells(Rows.Count, "B").End(xlUp).Row + 1
For i = 2 To ws1.Cells(Rows.Count, "A").End(xlUp).Row
If ws1.Cells(i, "B") = "" Then
If ws1.Cells(i, "C") = "1" Then
ws4.Cells(n, "B") = "開催日未定"
ws4.Range("C" & n & ":G" & n).Value = ws1.Range("E" & i & ":I" & i).Value
Else
If ws1.Cells(i, "D") = "1" Then
ws4.Cells(n, "B") = "年間費"
ws4.Range("C" & n & ":G" & n).Value = ws1.Range("E" & i & ":I" & i).Value
Else
End If
End If
If ws1.Cells(i, "J") <> "" Then
ws4.Cells(n, "H") = ws1.Cells(i, "J")
Else
ws4.Cells(n, "H") = ws1.Cells(i, "K")
End If
ws4.Cells(n, "I") = ws1.Cells(i, "L")
ws4.Cells(n, "J") = ws1.Cells(i, "M") & "万円×" & ws1.Cells(i, "N") & "枚"
ws4.Cells(n, "K") = ws1.Cells(i, "O") & "枚"
ws4.Cells(n, "L") = ws1.Cells(i, "Q") '備考
ElseIf ws1.Cells(i, "B") >= Date Then
ws4.Cells(n, "B") = ws1.Cells(i, "B")
ws4.Range("C" & n & ":G" & n).Value = ws1.Range("E" & i & ":I" & i).Value
If ws1.Cells(i, "J") <> "" Then
ws4.Cells(n, "H") = ws1.Cells(i, "J")
Else
ws4.Cells(n, "H") = ws1.Cells(i, "K")
End If
ws4.Cells(n, "I") = ws1.Cells(i, "L")
ws4.Cells(n, "J") = ws1.Cells(i, "M") & "万円×" & ws1.Cells(i, "N") & "枚"
ws4.Cells(n, "K") = ws1.Cells(i, "O") & "枚"
ws4.Cells(n, "L") = ws1.Cells(i, "Q") '備考
Else
End If
n = n + 1
Next i
With ws4.Sort
With .SortFields
.Clear
.Add Key:=ws4.Range("B5"), SortOn:=xlSortOnValues, Order:=xlAscending
End With
.SetRange ws4.Range("B5:L65536")
.Header = xlYes
.Apply
End With
Application.DisplayAlerts = False
wb1.Close
Application.DisplayAlerts = True
ws4.Select
End Sub
＜ 使用 Excel：Excel2016、使用 OS：Windows7 ＞
https://lilia-study.com/excel/vba-sample/mod-color/
https://kosapi.com/post-1207/
VBA 偶数行 色
みたいに検索すればいくらでも出てきます。
※個人的には、上記スレでoayncsFkk6さんが提案しているテーブルをおすすめしますが。
（フォーキー） 2023/01/09(月) 03:28:19
既に適切なコメントがありましたが、 別のアプローチとして、 ・塗りつぶし色を直接設定せずに（いったん解除して）、 ・条件付き書式で対応する という方法もあるでしょうね。( = MOD(ROW(A1),2)=0 という条件） これならソートしても崩れないでしょう。 もちろんVBAにすることも可能。 （γ） 2023/01/09(月) 05:45:47
偶数行ごとに色をつけるというのはどういうことなのかよくわからないですが、 テーブルにしてしまえばいいのでは？ テーブルの縞模様は、行数変えられますよ （´・ω・`） 2023/01/09(月) 08:31:33
頂いたURLを張り付けたのですが、何が問題なのでしょう。
Sub データの取込み_Click()
Dim Sname As String
Dim Sname2 As String
Dim ws1 As Worksheet
Dim ws4 As Worksheet
Dim filePath As String
Dim wb1 As Workbook
Dim MyRNG As Range
Dim i As Long
Dim j As Long
Dim k As Long
Dim n As Long
Sname = StrConv(Format(Date, "yyyy.m"), vbWide) '*シート名を○○○○.○月へ変更*'
On Error Resume Next
Set ws4 = ThisWorkbook.Worksheets(Sname)
On Error GoTo 0
'▼該当シートの有無で処理分岐
If ws4 Is Nothing Then
ThisWorkbook.Sheets("記入用").Copy before:=ThisWorkbook.Sheets("操作画面")
Set ws4 = ThisWorkbook.Sheets("操作画面").Previous
ws4.Name = Sname
ws4.Range("F3").Font.Size = 24 'フォントを24に設定
Else '既にシートが作成されていた場合(上書想定)
ws4.Range(ws4.Cells(6, "B"), ws4.Cells(ws4.Cells(ws4.Rows.Count, "B").End(xlUp).Row, "L")).ClearContents
End If
'*デーやの取込み【テスト】のExcelを取込み*'
ChDir ThisWorkbook.Path
filePath = Application.GetOpenFilename(FileFilter:="csvファイル(*.csv),*.csv", Title:="csvファイルの選択")
If filePath = "False" Then
MsgBox "ファイルが選択されなかったので処理を中止します。"
Exit Sub
Else
Set wb1 = Workbooks.Open(filePath)
Set ws1 = wb1.Worksheets(1)
End If
Sname2 = StrConv(Format(Date, " (yyyy.m.dd)"), vbWide) '*新しく作成した、シートのＦ列３行目に ○○○○．○○．○○を記入*'
ws4.Range("F3").Value = Sname2
n = ws4.Cells(Rows.Count, "B").End(xlUp).Row + 1
For i = 2 To ws1.Cells(Rows.Count, "A").End(xlUp).Row
If ws1.Cells(i, "B") = "" Then
If ws1.Cells(i, "C") = "1" Then
ws4.Cells(n, "B") = "開催日未定"
ws4.Range("C" & n & ":G" & n).Value = ws1.Range("E" & i & ":I" & i).Value
Else
If ws1.Cells(i, "D") = "1" Then
ws4.Cells(n, "B") = "年間費"
ws4.Range("C" & n & ":G" & n).Value = ws1.Range("E" & i & ":I" & i).Value
Else
End If
End If
If ws1.Cells(i, "J") <> "" Then
ws4.Cells(n, "H") = ws1.Cells(i, "J")
Else
ws4.Cells(n, "H") = ws1.Cells(i, "K")
End If
ws4.Cells(n, "I") = ws1.Cells(i, "L") '会合名
ws4.Cells(n, "J") = ws1.Cells(i, "M") & "万円×" & ws1.Cells(i, "N") & "枚"
ws4.Cells(n, "K") = ws1.Cells(i, "O") & "枚"
ws4.Cells(n, "L") = ws1.Cells(i, "Q") '備考
ElseIf ws1.Cells(i, "B") >= Date Then
ws4.Cells(n, "B") = ws1.Cells(i, "B")
ws4.Range("C" & n & ":G" & n).Value = ws1.Range("E" & i & ":I" & i).Value
If ws1.Cells(i, "J") <> "" Then
ws4.Cells(n, "H") = ws1.Cells(i, "J")
Else
ws4.Cells(n, "H") = ws1.Cells(i, "K")
End If
ws4.Cells(n, "I") = ws1.Cells(i, "L") '会合名
ws4.Cells(n, "J") = ws1.Cells(i, "M") & "万円×" & ws1.Cells(i, "N") & "枚"
ws4.Cells(n, "K") = ws1.Cells(i, "O") & "枚"
ws4.Cells(n, "L") = ws1.Cells(i, "Q") '備考
Else
End If
n = n + 1
Next i
With ws4.Sort
With .SortFields
.Clear
.Add Key:=ws4.Range("B5"), SortOn:=xlSortOnValues, Order:=xlAscending
End With
.SetRange ws4.Range("B5:L65536")
.Header = xlYes
.Apply
End With
For j = 6 To 65536
If ws4.Cells(j, 1).Value Mod 2 = 0 Then
ws4.Range(ws4.Cells(j, "B"), ws4.Cells(j, "L")).Interior.Color = RGB(226, 239, 218)
End If
Next j
Application.DisplayAlerts = False
wb1.Close
Application.DisplayAlerts = True
ws4.Select
End Sub
（超初心者） 2023/01/09(月) 17:46:21
>If Cells(j, 1).Value Mod 2 = 0 Then
↓
If j Mod 2 = 0 Then
（フォーキー） 2023/01/09(月) 18:20:52
ありがとうございます。
しかし、偶数行の並び替えができずの状況です。
調べてみます。
（超初心者） 2023/01/09(月) 18:53:12
>しかし、偶数行の並び替えができずの状況です。
最初の質問は、
>偶数列になるよう色付けしたのですが、 >すべて色付けされてしまいます。
でしたよね？
色付けではなく、ソートの質問だったんですか？
（フォーキー） 2023/01/09(月) 19:05:08
ちょっとおっしゃることを理解しかねています。
ソートができていないのではなく、 偶数行以外にも色が付いている、のではないですか？
1.値の転記しかしていないようだから、 （元々,"記入用"シートをコピーして作った）シートに色がついていて、 2.ソート後に、加えて偶数行ごとに色を付けたから、奇数行のいくつかにも色がついている。 ということでしょう。
ではどうするか。以下のいずれかでしょう。
(1)最初に塗りつぶし色を初期化する方法。
Else '既にシートが作成されていた場合(上書想定)
ws4.Range(ws4.Cells(6, "B"), ws4.Cells(ws4.Cells(ws4.Rows.Count, "B").End(xlUp).Row,"L")).ClearContents
End If
のところです。
.ClearContents を .Clear に変更して色を初期化しておく。
・ClearContentsは、数式と値だけを消す命令です。
・Clearは 書式も含めて全体を消します。
もしくは、 (2)偶数行は色をつけ、奇数行は色をクリアーするように変更する。 ということではないですか？ （γ） 2023/01/10(火) 15:20:33
上記を使用しないとすれば、前の発言のような対応になりますが、
ソートが予定されているなら、根本的な対策をとったほうが良いとは思います。
（γ） 2023/01/10(火) 15:32:06
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.