Excel VBA質問箱 IV

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

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


8562 / 13645 ツリー ←次へ | 前へ→

【32256】抽出・入力方法 どんぼ 05/12/11(日) 20:43 質問[未読]
【32261】Re:抽出・入力方法 ponpon 05/12/11(日) 22:19 お礼[未読]
【32552】Re:抽出・入力方法 どんぼ 05/12/17(土) 9:19 質問[未読]
【32556】Re:抽出・入力方法 ponpon 05/12/17(土) 12:42 発言[未読]
【32558】Re:抽出・入力方法 ponpon 05/12/17(土) 16:06 発言[未読]
【32562】Re:抽出・入力方法 どんぼ 05/12/17(土) 21:35 お礼[未読]

【32256】抽出・入力方法
質問  どんぼ  - 05/12/11(日) 20:43 -

引用なし
パスワード
   エクセルで下記のような表があり、品名を入力しマクロを実行すると、
ラベル番号が入り、1つ前の情報(同品名)を取得する仕組みを作成しています。
ラベル番号は出来たのですが、項0002のデータ(行)が取得できません。
データ量が膨大ですので、簡単に出来る方法がありましたらお願いいたします。


項  品名  ラベルNo 備考
0001 りんご 10001
0002 アイス 20001
0003 弁当  30001 
0004 りんご 10002
.  
.  
3000 アイス 20002  <新規入力


Sub TEST()
  Dim wkSheet As Worksheet
  Dim rng As Range
  Dim LNo As Long
  Dim row As Long
  
  Set wkSheet = Worksheets("test")
  
  With wkSheet
    Set rng = wkSheet.Range("A1").SpecialCells(xlCellTypeLastCell)
  
    row = .Cells.Find("*", rng, , , xlByRows, xlPrevious).row
    LNo = wkSheet.Evaluate _
      ("=LARGE(IF(B2:B" & row & "=""りんご"",C2:C" & row & ",),1)")
    .Range("C" & row).Value = LNo + 1
  End With
      
End Sub

【32261】Re:抽出・入力方法
お礼  ponpon  - 05/12/11(日) 22:19 -

引用なし
パスワード
   こんばんは。

もっといい方法があると思いますが、

>品名を入力しマクロを実行すると、

とあるのでイベントマクロにしてみました。
Worksheets("test")のシートモジュールに貼り付けて、
試してください。

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim myNO As Long
  Dim i As Long

  Application.ScreenUpdating = False
  With Target
   If .Count > 1 Then Exit Sub
   If IsEmpty(.Value) Then Exit Sub
   If Not Application.Intersect(Target, Range("B:B")) Is Nothing Then
    Application.EnableEvents = False
    For i = .row - 1 To 2 Step -1
      If Cells(i, "B").Value = .Value Then
       myNO = Cells(i, "C") + 1
       Exit For
      Else
       myNO = (Left$(Application.Max(Range("C:C")), 1) + 1) * 10000 + 1
      End If
    Next
  
    .Offset(, -1).Value = Format(.row - 1, "0000")
    .Offset(, 1).Value = myNO
   
    Application.EnableEvents = True
   End If
  End With
  Application.ScreenUpdating = True

End Sub

【32552】Re:抽出・入力方法
質問  どんぼ  - 05/12/17(土) 9:19 -

引用なし
パスワード
   ponponさん、返事が遅くなり申し訳ございません。
参考になりました。有難うございます。

使用方法が変更になり、再度、作り直している所です。
ラベルNoは、日付+商品番号+番号になります。
日付は入力した日になります。
ponponさんのコードを多少変更すれば良いのでしょうか。


通項 項  品名  ラベルNo  備考
0001 1   りんご 5121410001
0002 1   アイス 5121420001
0003 1   弁当  5121430001 
0004 2   りんご 5121710001
0005 3  りんご 5121710002  


0999 2  アイス 5121720001
1000 800 りんご 5121710801 <新規入力

【32556】Re:抽出・入力方法
発言  ponpon  - 05/12/17(土) 12:42 -

引用なし
パスワード
   こんにちは。

>ラベルNoは、日付+商品番号+番号

商品番号???

前回も今回も商品番号は、一番はじめ10000、新しいものが出ると20000、
次は30000となっているようですが・・・。

商品番号の一覧がどこかにあるのであれば、VLOOKUP関数やMATCH関数、FIND関数
などを使って、番号を参照する必要があります。


いろいろとやってみて、一応できたのですが、課題があります。
課題が解決できないときは、捨てて、識者の回答をお待ちください。


=前提=
 ◎A列の書式はは、文字列にしてください。(マクロではしていません)
 ◎C列の書式は、数値にしてください。(〃)
 ◎商品番号は、前回と同じように10000、20000、30000・・・としています。

=課題=
 このままで行くと2010年になると使えなくなります。
 (いろいろ考えたのですが、すみません)


以下コードです。ジーとモジュールに貼り付けて試してください。

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim myNO As Double
 
  Application.ScreenUpdating = False
  With Target
   If .Count > 1 Then Exit Sub
   If IsEmpty(.Value) Then Exit Sub
   If Not Application.Intersect(Target, Range("C:C")) Is Nothing Then
    Application.EnableEvents = False
    If .row = 2 Then
     myNO = CDbl(Format(Date, "yymmdd") & "10001")
     .Offset(, -1).Value = 1
    End If
  
   
    For i = .row - 1 To 2 Step -1
      If Cells(i, "C").Value = .Value Then
       .Offset(, -1).Value = Cells(i, "B").Value + 1
       myNO = CDbl(Format(Date, "yymmdd") & Mid$(Cells(i, "D"), 6) + 1)
       Exit For
      Else
       .Offset(, -1).Value = 1
       myNO = CDbl(Format(Date, "yymmdd") & _
       Int((Mid$(Application.Max(Range("D:D")), 6) _
       / 10000) + 1) * 10000 + 1)

      End If
    Next
  
    .Offset(, -2).Value = Format(.row - 1, "00000")
    .Offset(, 1).Value = myNO
   
    Application.EnableEvents = True
   End If
  End With
  Application.ScreenUpdating = True

End Sub

【32558】Re:抽出・入力方法
発言  ponpon  - 05/12/17(土) 16:06 -

引用なし
パスワード
   こんにちは。
文字列で対応することで課題は解消しました。
作業列にAD列を使用しています。
べたべたのコードで醜いですが・・・・。

=前提=
 ◎A列の書式は、文字列にしてください。(マクロではしていません)
 ◎C列の書式も、文字列にしてください。(〃)
 ◎商品番号は、前回と同じように10000、20000、30000・・・としています。

以下コードです。

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim myNO As String
  Dim myR As Range
 
  Application.ScreenUpdating = False
  With Target
   If .Count > 1 Then Exit Sub
   If IsEmpty(.Value) Then Exit Sub
   If Not Application.Intersect(Target, Range("C:C")) Is Nothing Then
    Application.EnableEvents = False
    If .row = 2 Then
     myNO = Format(Date, "yymmdd") & "10001"
     .Offset(, -1).Value = 1
    End If
  
   
    For i = .row - 1 To 2 Step -1
      If Cells(i, "C").Value = .Value Then
       .Offset(, -1).Value = Cells(i, "B").Value + 1
       myNO = Format(Date, "yymmdd") & Mid$(Cells(i, "D"), 7) + 1
       Exit For
      Else
      Set myR = Range("D2", Range("D65536").End(xlUp))
        With myR.Offset(, 26)
               .Value = "=right(d2,len(D2)-6)"
               .Value = .Value
        End With
       .Offset(, -1).Value = 1
       myNO = Format(Date, "yymmdd") & _
       (Int(Application.Max(Range("AD:AD")) / 10000) + 1) * 10000 + 1

      End If
    Next
    .Offset(, -2).Value = Format(.row - 1, "00000")
    .Offset(, 1).Value = myNO
    Range("AD:AD").ClearContents
   
    Application.EnableEvents = True
   End If
  End With
  Application.ScreenUpdating = True

End Sub

【32562】Re:抽出・入力方法
お礼  どんぼ  - 05/12/17(土) 21:35 -

引用なし
パスワード
   ponponさん、有難うございます。
参考にして何とか出来ました。

データが膨大で他の処理が複雑な為、処理スピードが遅いのが難点ですが、
頑張って改善しようと思います。
有難うございました。

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