[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『台帳から3つのシートに振り分けるコードがうまくいきません。教えてください。』（たきち）
コードをつなぎつなぎ、作ったのですが、動きません。
教えてください。
注文台帳というシートから、データを3つのシート(すべて同じブックにあります)に転送したいのです。
注文台帳は、B列からU列までで、そのうち、B、L、М、О、S、Tは関数式が入っています。 データはB列11からです。 U列に日付を入れると、T列に、その品目によって、整数の1から3までが自動的に入力されます。 1なら、経費Ａ、2なら、経費Ｂ、3なら、その他経費 のシートにデータが転送され、元の注文台帳のデータは削除したいのです。が、うまく動きません。
Sub Macro80()
Dim i As Long
Dim j As Long
Dim ws As Worksheet
With Sheets("注文台帳")
For i = 11 To .Cells(Rows.Count, "B").End(xlUp).Row
If .Cells(i, "U").Value <> "" Then
Select Case .Cells(i, "T").Value
Case 1: Set ws = Sheets("経費Ａ")
Case 2: Set ws = Sheets("経費Ｂ")
Case Else: Set ws = Sheets("その他経費")
End Select
j = ws.Cells(Rows.Count, "B").End(xlUp).Row + 1
.Rows(i).Cut
ws.Rows(j).Insert Shift:=xlDown
End If
Next i
End With
Range("B11:B" & Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
(たきち) 2019/06/19(水) 20:09
＜ 使用 Excel：Excel2016、使用 OS：unknown ＞
どうなるのでしょうか。
（マナ） 2019/06/19(水) 20:20
（マナ） 2019/06/19(水) 20:33
こんばんは！
最後のフレーズだけ明示してなかったので ws を付けてみました。(すみません。動かしていません。）
フレーズごとに出入りしていた方がみやすいでしょ？？？
そんなことない？？？(^^;
Option Explicit
Sub Macro80()
Dim i As Long
Dim j As Long
Dim ws As Worksheet
With Sheets("注文台帳")
For i = 11 To .Cells(Rows.Count, "B").End(xlUp).Row
If .Cells(i, "U").Value <> "" Then
Select Case .Cells(i, "T").Value
Case 1
Set ws = Sheets("経費Ａ")
Case 2
Set ws = Sheets("経費Ｂ")
Case Else
Set ws = Sheets("その他経費")
End Select
j = ws.Cells(Rows.Count, "B").End(xlUp).Row + 1
.Rows(i).Cut
ws.Rows(j).Insert Shift:=xlDown
End If
Next i
End With
ws.Range("B11:B" & Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
（SoulMan） 2019/06/19(水) 20:41
また、カット＆インサートしてますが、カット＆ペーストでも同じことになるとおもいます。
（もこな２） 2019/06/19(水) 21:21
（たきち） 2019/06/19(水) 21:27
Select Case .Cells(i, "T").Value
Case 1
Set ws = Sheets("経費Ａ")
Case 2
Set ws = Sheets("経費Ｂ")
Case 3
Set ws = Sheets("その他経費")
Case Else
MsgBox i & "行目に想定外の値があります"
End Select
＞それが原因で動かなくなるのですか。
いえ、そういうことではなくて、項目行があるなら、1行ずつ見ずとも
(1)オートフィルタを設定し、 (2)T列が1のものを抽出して、経費Ａシートへコピペ (3)T列が2のものを抽出して、経費Ｂシートへコピペ (4)T列が3のものを抽出して、その他経費シートへコピペ (5)元データをクリア
というような処理でもできるだろうな～とおもっただけです。
（もこな２） 2019/06/20(木) 04:30
Sub Macro80_改()
Dim i As Long
Dim 最終行 As Long
Dim ふらぐ As Boolean
With Sheets("注文台帳")
最終行 = .Cells(Rows.Count, "B").End(xlUp).Row
If 最終行 < 11 Then
MsgBox "処理データがありません"
Exit Sub
End If
For i = 11 To .Cells(最終行, "B").End(xlUp).Row
If .Cells(i, "U").Value <> "" Then
'▼コピーのみ（貼付はしない）
.Range(.Cells(i, "B"), .Cells(i, "U")).Copy
'▼条件分岐
Select Case .Cells(i, "T").Value
Case 1
Sheets("経費Ａ").Cells(.Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial
Case 2
Sheets("経費Ｂ").Cells(.Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial
Case 3
Sheets("その他経費").Cells(.Rows.Count, "B").End(xlUp).Offset(1).PasteSpecial
Case Else
.Range(.Cells(i, "B"), .Cells(i, "U")).Interior.Color = vbRed
ふらぐ = True
End Select
End If
Next i
If ふらぐ Then
MsgBox "処理できなかった行があります" & vbCrLf & "確認してから元データを手動で削除してください"
Else
If MsgBox("転記処理が完了しました" & vbCrLf & "元データを削除してよろしいですか？") = vbYes Then
.Cells("B11", .Cells(最終行, "U")).Delete
End If
End If
End With
End Sub
※一度実行テストまでしましたが、保存するまえにクラッシュして作り直したので、テストまでする元気がありません。
コンパイルは通りましたが、雰囲気的なものとしてご理解ください。
（もこな２） 2019/06/21(金) 07:22
Sub Macro80_改乙()
Dim i As Long
Dim 最終行 As Long
Dim ふらぐ As Boolean
Dim MyRNG As Range
With Sheets("注文台帳")
最終行 = .Cells(Rows.Count, "B").End(xlUp).Row
If 最終行 < 11 Then
MsgBox "処理データがありません"
Exit Sub
End If
For i = 11 To .Cells(最終行, "B").End(xlUp).Row
If .Cells(i, "U").Value <> "" Then
'▼対象のセル範囲を覚える
Set MyRNG = .Range(.Cells(i, "B"), .Cells(i, "U"))
'▼条件分岐
Select Case .Cells(i, "T").Value
Case 1
MyRNG.Copy Sheets("経費Ａ").Cells(.Rows.Count, "B").End(xlUp).Offset(1)
Case 2
MyRNG.Copy Sheets("経費Ｂ").Cells(.Rows.Count, "B").End(xlUp).Offset(1)
Case 3
MyRNG.Copy Sheets("その他経費").Cells(.Rows.Count, "B").End(xlUp).Offset(1)
Case Else
MyRNG.Interior.Color = vbRed
ふらぐ = True
End Select
End If
Next i
If ふらぐ Then
MsgBox "処理できなかった行があります" & vbCrLf & "確認してから元データを手動で削除してください"
Else
If MsgBox("転記処理が完了しました" & vbCrLf & "元データを削除してよろしいですか？") = vbYes Then
.Cells("B11", .Cells(最終行, "U")).Delete
End If
End If
End With
End Sub
（もこな２） 2019/06/21(金) 07:29
Sub Macro80_改乙_修正()
Dim i As Long
Dim 最終行 As Long
Dim ふらぐ As Boolean
Dim MyRNG As Range
With Sheets("注文台帳")
最終行 = .Cells(Rows.Count, "B").End(xlUp).Row
If 最終行 < 11 Then
MsgBox "処理データがありません"
Exit Sub
End If
For i = 11 To 最終行
If .Cells(i, "U").Value <> "" Then
'▼対象のセル範囲を覚える
Set MyRNG = .Range(.Cells(i, "B"), .Cells(i, "U"))
'▼条件分岐
Select Case .Cells(i, "T").Value
Case 1
MyRNG.Copy Sheets("経費Ａ").Cells(.Rows.Count, "B").End(xlUp).Offset(1)
Case 2
MyRNG.Copy Sheets("経費Ｂ").Cells(.Rows.Count, "B").End(xlUp).Offset(1)
Case 3
MyRNG.Copy Sheets("その他経費").Cells(.Rows.Count, "B").End(xlUp).Offset(1)
Case Else
MyRNG.Interior.Color = vbRed
ふらぐ = True
End Select
End If
Next i
If ふらぐ Then
MsgBox "処理できなかった行があります" & vbCrLf & "確認してから元データを手動で削除してください"
Else
If MsgBox("転記処理が完了しました" & vbCrLf & "元データを削除してよろしいですか？", vbYesNo) = vbYes Then
.Cells("B11", .Cells(最終行, "U")).Delete
End If
End If
End With
End Sub
また、オートフィルタ版もつくってみました。
【訂正のためいったん削除】
どちらでも出来ると思いますので、お好きな方をステップ実行して研究してみて、使えそうな部分をご自身のコードに組み込んでみてください。
（もこな２） 2019/06/21(金) 19:48
Sub オートフィルタ版()
Dim Sh名 As Variant
Dim 抽出条件 As Variant
Dim i As Long
Dim MyRNG As Range
Sh名 = Array("経費Ａ", "経費Ｂ", "その他経費")
抽出条件 = Array("1", "2", "3")
With Sheets("注文台帳")
.AutoFilterMode = False 'オートフィルタ解除
.Range("B11").AutoFilter Field:=20, Criteria1:="<>" 'オートフィルタでU列のうち空白以外のものを抽出
With .AutoFilter.Range
'▼データが無いときは処理中止
If .Rows.Count = 1 Then
MsgBox "データがありません"
.AutoFilter 'オートフィルタ解除
Exit Sub
End If
'▼抽出＆コピペ（ループ処理）
For i = 0 To 2
.Parent.Range("B11").AutoFilter Field:=19, Criteria1:=抽出条件(i)
.Offset(1).Copy Sheets(Sh名(i)).Cells(.Rows.Count, "B").End(xlUp).Offset(1)
Next i
'▼T列が1～3のものをまとめて抽出
.Parent.Range("B11").AutoFilter Field:=19, Criteria1:=抽出条件, Operator:=xlFilterValues
'▼抽出されているものを削除
Application.DisplayAlerts = False
.Offset(1).Delete Shift:=xlUp
Application.DisplayAlerts = True
.AutoFilter 'オートフィルタ解除
End With
End With
End Sub
（もこな２） 2019/06/21(金) 22:21
SoulManさんご指摘のシート指定漏れは
with～end withの中に入れるとよいです。
＞ End With
＞ Range("B11:B" & Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
↓
.Range("B11:B" & Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
あと、
＞If .Cells(i, "U").Value <> "" Then
これは、必要ありますか。
（マナ） 2019/06/22(土) 08:55
おはようございます。
>.Cells(i, "T").Value
これが、、文字だと推測して
CLng(.Cells(i, "T").Value)
とか、
Val(.Cells(i, "T").Value）
または、、
>Case 1
↓
Case "1"
にしてみてはどうでしょうか？ （SoulMan） 2019/06/22(土) 09:47
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.