Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


6997 / 13644 ツリー ←次へ | 前へ→

【41878】困っています 四苦八苦 06/8/24(木) 21:13 質問[未読]
【41881】1文字ずつセルに分割する方法? Ned 06/8/24(木) 22:09 発言[未読]
【41882】Re:困っています Kein 06/8/24(木) 22:22 回答[未読]
【41885】Re:困っています 四苦八苦 06/8/24(木) 22:53 お礼[未読]

【41878】困っています
質問  四苦八苦  - 06/8/24(木) 21:13 -

引用なし
パスワード
   sheet1とsheet2があります。sheet1には

  A  B      C    D   E   F
1  No 品名    品番  単価 数量  合計
2  1  はさみ  BT265987  260
3  2  消しゴム H5003Y7F4 55
4  3  修正ペン 8P1G5502  180
5  4  カッターナイフ 10993R4F  120
6  5  封筒   6U222D8WB 210
7  6  鉛筆   LGG6Y79S  150
       ・
       ・
       ・
31 30  ボールペン X4X309K7  35

となっていて、「合計」のF行には31行目まで予め関数が入っています。
「数量」の行に手入れで数字を入力すると、当然合計の欄に単価と数量をかけた数字が自動的に表示されます。
  A  B      C    D   E   F
1  No 品名    品番  単価 数量  合計
2  1  はさみ  BT265987  260
3  2  消しゴム H5003Y7F4 55  3   165
4  3  修正ペン 8P1G5502  180
5  4  カッターナイフ 10993R4F  120
6  5  封筒   6U222D8WB 210  7   1470
7  6  鉛筆   LGG6Y79S  150  1   150
       ・
       ・
       ・
31 30  ボールペン X4X309K7  30

sheet1のどこかにコマンドボタンを作っておいて、これをクリックすると、Sheet2に、

  A  BCDEFGHIJ  K   L    
1 No   品番   数量 品名
2 1  H5003Y7F4  3  消しゴム
3 2  6U222D8WB  7  封筒
4 3  LGG6Y79S  1  鉛筆

と反映されるようにしたのですが、一番の難関は、sheet1の「品番」C行一つのセルに表示されている8桁ないし、9桁の数字をsheet2にはB〜J行それぞれ1行につき1個数字が入るようにしたいということです。
どなたか素晴らしい知恵を授けてください。

【41881】1文字ずつセルに分割する方法?
発言  Ned  - 06/8/24(木) 22:09 -

引用なし
パスワード
   ▼四苦八苦 さん:
こんにちは。
1)AdvancedFilterメソッドで別シートに抽出する。
2)C列の前に8列挿入する。
3)B2:B最終行までTextToColumnsメソッドで分割する。
 (メニュー[データ]-[区切り位置]..を参考に、ほぼマクロ記録だけでできると思います)

【41882】Re:困っています
回答  Kein  - 06/8/24(木) 22:22 -

引用なし
パスワード
   ボタンは不要です。Sheet1 のシートモジュールに、以下のイベントマクロを
入れて下さい。
E2:E31 の範囲で単一のセルに数値を入力したとき、その行のデータを
チェック & 取得して自動的に Sheet2 の適切なセル位置へ転記します。
Sheet2 は IV列 を作業列とします。ここへ入力された品番と照らし合わせ、
転記しようとしている品番が見つからないときは、IV列の最終入力行の
一つ下の行の A:L列 へ転記します。逆に品番が見つかったときは、その行の
K列 の数量のみを更新して終わります。

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Num As Long, Amot As Long
  Dim Gods As String, CkV As String
  Dim CkR As Variant
  Const PsLine As String = _
  "[x][x][x][x][x][x][x][x][x]"

  If Intersect(Target, Range("E2:E31")) _
  Is Nothing Then Exit Sub
  With Target
   If .Count > 1 Then Exit Sub
   If IsEmpty(.Value) Then Exit Sub
   If Not IsNumeric(.Value) Then Exit Sub
   If WorksheetFunction _
   .CountA(.Offset(, -4).Resize(, 5)) < 5 Then Exit Sub
   Num = .Offset(, -4).Value
   Gods = .Offset(, -3).Value
   CkV = .Offset(, -2).Value
   Amot = .Value
  End With
  With Worksheets("Sheet2")
   CkR = Application.Match(CkV, .Range("IV:IV"), 0)
   If IsError(CkR) Then
     With .Range("IV65536").End(xlUp)
      .Offset(1).Value = CkV
      .Offset(1, -255).Value = Num
      .Offset(1).Parse PsLine, .Offset(1, -254)
      .Offset(1, -245).Value = Amot
      .Offset(1, -244).Value = Gods
     End With
   Else
     .Cells(CkR, 11).Value = Amot
   End If
  End With
End Sub

【41885】Re:困っています
お礼  四苦八苦  - 06/8/24(木) 22:53 -

引用なし
パスワード
   お二方、まことにありがとうございます。さっそく実行してみます。

6997 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free