Excelで2つの列を1つの列に合わせたい


今、I列とJ列にデータが入っております。J列のデータにおきまして、完全一致で“りんご”というキーワードに該当するセルがありましたら。
そのセルを、左のI列に移動させたいです。

I列には既にデータが入っているので、I列自体には関数などを入れることができず…困っております。

ちなみにJ列にある“りんご”というデータですが、左隣のI列は必ず空白セルになっているので、I列のデータが書き換わることはないです。

I列のデータを保持しつつ、J列のデータをI列に持っていけたらと思います。
よろしくお願い致します。

回答の条件
  • 1人10回まで
  • 登録:2018/03/13 05:10:09
  • 終了:2018/03/30 08:07:23

ベストアンサー

id:a-kuma3 No.2

a-kuma3回答回数4739ベストアンサー獲得回数20322018/03/13 08:43:58

ポイント900pt

下記のマクロを標準モジュールにはりつけて、copy_cell サブルーチンを実行してください。

Function is_blank_cell(c)
    is_blank_cell = IsEmpty(c) Or c.Value = ""
End Function

Sub copy_cell()
    word = "りんご"
    dest_col = 9        ' I列
    src_col = 10        ' J列
    last_row = Cells(Rows.Count, src_col).End(xlUp).Row
    For r = 2 To last_row
        If Cells(r, src_col).Value = word And is_blank_cell(Cells(r, dest_col)) Then
            Cells(r, dest_col).Value = Cells(r, src_col).Value
        End If
        DoEvents
    Next
End Sub

何となく、2行目から始めてみました。
J列が複写対象になった場合には、その隣の I列のセルは必ず空白だということですが、いちおう空白かどうかの確認もしています。


因みに、「複写」じゃなくて「移動」にこだわりますか?

他4件のコメントを見る
id:a-kuma3

悪意等あってコメントしたわけではありません。

ぼくの書き方が悪かったかな。
回答歴を見てて、そんな方ではないことは分かってコメントしてました。
全然、気に障ったとかないですよ :-)

2018/03/14 10:25:51
id:moon-fondu

遅くなりましてすみません、ありがとうございました。お二人のレビューは内容が深いですね、勉強になります(^^;

2018/03/30 08:02:21

その他の回答(3件)

id:Asayuri No.1

Asayuri回答回数123ベストアンサー獲得回数262018/03/13 07:55:45

ポイント300pt

 
関数の式をエクセルファイルで作成しましたので、
 
次のURLからダウンロードしてください。

http://firestorage.jp/download/83c2c76af1d2c84fb7b3efdf10615849e6b35688
 
H列をコピーしてI列に値貼り付けすればご希望のデータが出来上がります。
 
よろしくお願いします。
 

他1件のコメントを見る
id:Asayuri

 
うまくできて とてもうれしいです。
 
これからも エクセル質問してくださいね。
 

2018/03/14 20:05:55
id:moon-fondu

遅くなりましてすみません、ありがとうございました!

2018/03/30 07:57:37
id:a-kuma3 No.2

a-kuma3回答回数4739ベストアンサー獲得回数20322018/03/13 08:43:58ここでベストアンサー

ポイント900pt

下記のマクロを標準モジュールにはりつけて、copy_cell サブルーチンを実行してください。

Function is_blank_cell(c)
    is_blank_cell = IsEmpty(c) Or c.Value = ""
End Function

Sub copy_cell()
    word = "りんご"
    dest_col = 9        ' I列
    src_col = 10        ' J列
    last_row = Cells(Rows.Count, src_col).End(xlUp).Row
    For r = 2 To last_row
        If Cells(r, src_col).Value = word And is_blank_cell(Cells(r, dest_col)) Then
            Cells(r, dest_col).Value = Cells(r, src_col).Value
        End If
        DoEvents
    Next
End Sub

何となく、2行目から始めてみました。
J列が複写対象になった場合には、その隣の I列のセルは必ず空白だということですが、いちおう空白かどうかの確認もしています。


因みに、「複写」じゃなくて「移動」にこだわりますか?

他4件のコメントを見る
id:a-kuma3

悪意等あってコメントしたわけではありません。

ぼくの書き方が悪かったかな。
回答歴を見てて、そんな方ではないことは分かってコメントしてました。
全然、気に障ったとかないですよ :-)

2018/03/14 10:25:51
id:moon-fondu

遅くなりましてすみません、ありがとうございました。お二人のレビューは内容が深いですね、勉強になります(^^;

2018/03/30 08:02:21
id:takashi_m17 No.3

たか回答回数106ベストアンサー獲得回数122018/03/13 09:12:17

ポイント10pt

1)フィルタでI列の空白だけを抽出
2)空白セルに関数を入れる
3)フィルタで抽出された空白セル全てにコピペ

おまけ)関数のままで問題ならばそこで値の貼り付けでコピペ


フィルタで隠れている部分はコピペの対象外なので、元のI列データは維持したまま出来るかと。

id:moon-fondu

空白セルの抽出はやったことがないものでして…。Asayuriさんのファイルに入っていた関数や、a-kuma3さんのマクロで、うまく変更できました(^^;

2018/03/13 21:50:49
id:Z1000S No.4

Z1000S回答回数30ベストアンサー獲得回数212018/03/14 07:16:34

ポイント100pt

私の思うところが伝わっていなかったようなので。

「sTarget」に処理対象文字列(今回の例であれば「りんご」)を指定して実行して下さい。

Public Sub transferJ2I(ByVal sTarget As String)

Const TARGET_SHEET_NAME As String = "Sheet1"

'移動元列(J)
Const SOURCE_COL As Long = 10

'移動先列(I)
Const DEST_COL As Long = 9

Dim lHeaderRow As Long
Dim xlFilterRow As Range
Dim lTargetCounts As Long
Dim lTargetRows() As Long
Dim lCount As Long
Dim i As Long

With ThisWorkbook.Worksheets(TARGET_SHEET_NAME)
'オートフィルタの設定状態
If .AutoFilterMode = True Then
'オートフィルタが設定済みなら、一旦解除
.AutoFilter.Range.AutoFilter
End If

'オートフィルタのヘッダとなる行を取得
If .Cells(1, SOURCE_COL).Value <> "" Then
lHeaderRow = 1
Else
lHeaderRow = .Cells(1, SOURCE_COL).End(xlDown).Row
End If

'指定文字データを抽出
With .Range(.Cells(1, SOURCE_COL), .Cells(.Rows.Count, SOURCE_COL))
'オートフィルタ実行
.AutoFilter Field:=1, Criteria1:=sTarget

'絞り込まれた件数取得(ヘッダー行までの行が含まれているので、その分を補正)
lTargetCounts = .CurrentRegion.Resize(, 1).SpecialCells(xlVisible).Count - lHeaderRow

If lTargetCounts > 0 Then
'対象の行を格納する配列初期化
ReDim lTargetRows(lTargetCounts - 1)

For Each xlFilterRow In .CurrentRegion.Resize(, 1).SpecialCells(xlVisible)
'対象データの行の取得
If xlFilterRow.Row > lHeaderRow Then
'ヘッダー行以降
lTargetRows(lCount) = xlFilterRow.Row

lCount = lCount + 1
End If
Next xlFilterRow
End If
End With

'オートフィルタ解除
.AutoFilter.Range.AutoFilter

If .Cells(lHeaderRow, SOURCE_COL).Value = sTarget Then
ReDim Preserve lTargetRows(lCount)

lTargetRows(lCount) = lHeaderRow

lTargetCounts = lTargetCounts + 1
End If

'データの移動
For i = 0 To lTargetCounts - 1
.Cells(lTargetRows(i), SOURCE_COL).Cut Destination:=.Cells(lTargetRows(i), DEST_COL)
Next i
End With

Debug.Print "Done."

End Sub


実行前にオートフィルタが設定されている場合、オートフィルタは解除されます。
必要であれば、処理を追加すれば元に戻せます。(多分)(未確認)

id:a-kuma3

ぼくも、ループ回数を削減してみました。

Sub copy_cell()
    word = "りんご"
    dest_col = 9        ' I列
    src_col = 10        ' J列

    last_row = Cells(Rows.Count, src_col).End(xlUp).Row
    
    Set area = Range(Cells(1, dest_col), Cells(last_row, src_col))

    area.AutoFilter Field:=1, Criteria1:="="
    area.AutoFilter Field:=2, Criteria1:=word

    Set area = area.Offset(1, 0).Resize(area.Rows.Count - 1, area.Columns.Count)
    Set area = area.SpecialCells(xlCellTypeVisible)
    area.FillLeft

    area.AutoFilter

End Sub

列が隣り合ってるのが幸い。
来週のぼくには、何をやってるのか分からなくなってるな :-)

2018/03/14 17:39:46
id:moon-fondu

一瞬で移動できました、ありがとうございました(^^;

2018/03/30 08:06:10

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません