Excel VBA質問箱 IV

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

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


13887 / 76738 ←次へ | 前へ→

【68353】Re:セルを比べて同じなら・・・
発言  Jaka  - 11/2/25(金) 16:36 -

引用なし
パスワード
   しみったれて、1行分の配列しか使ってないけど、
多少は早くなると思います。

Sub 品番抽出プログラム()

 Dim BOOKNAME As String  '元ファイル名
 Dim DISTINATION As String '変更ファイル名
 Dim MAIN As String    'アクティブシート名
 Dim KITEN As Range    '原点
 Dim C As Integer     '表MAIN最終行
 Dim HINBAN As String   '品番名
 Dim A As Integer     'カウンタ
 Dim B As Integer     'サブカウンタ
 Dim FLAG As String

Dim TB(1 To 6) As Variant '←ちゃんと2次元にしようかと思ったけれど1次元

 'ファイルを開く
  BOOKNAME = Application.GetOpenFilename(MultiSelect:=False)
  Workbooks.Open Filename:=BOOKNAME

  BOOKNAME = Right(BOOKNAME, 16)
  Workbooks(BOOKNAME).Activate


 'シート名確保
  MAIN = Left(BOOKNAME, 12)

  'アクティブシート名取得
  Workbooks(BOOKNAME).Activate
  Set KITEN = Worksheets(MAIN).Range("A1")
  C = KITEN.CurrentRegion.Rows.Count    '最終行取得

  A = 2
 
  Do While Len(Cells(A, 6)) > 0  'セルの文字数0ならば
   A = A + 1
   B = A - 1

   Sheets(MAIN).Select
   FLAG = StrComp(Cells(A, 6), Cells(B, 6), vbTextCompare)
 
   If FLAG = 0 Then '一致していれば
   'Worksheets(MAIN).Cells(B, 14).Value = Worksheets(MAIN).Cells(B, 14).Value + Worksheets(MAIN).Cells(A, 14).Value
'   Worksheets(MAIN).Cells(B, 15).Value = Worksheets(MAIN).Cells(B, 15).Value + Worksheets(MAIN).Cells(A, 15).Value
'   Worksheets(MAIN).Cells(B, 16).Value = Worksheets(MAIN).Cells(B, 16).Value + Worksheets(MAIN).Cells(A, 16).Value
'   Worksheets(MAIN).Cells(B, 17).Value = Worksheets(MAIN).Cells(B, 17).Value + Worksheets(MAIN).Cells(A, 17).Value
'   Worksheets(MAIN).Cells(B, 18).Value = Worksheets(MAIN).Cells(B, 18).Value + Worksheets(MAIN).Cells(A, 18).Value
'   Worksheets(MAIN).Cells(B, 19).Value = Worksheets(MAIN).Cells(B, 19).Value + Worksheets(MAIN).Cells(A, 19).Value
'   Worksheets(MAIN).Cells(B, 20).Value = Worksheets(MAIN).Cells(B, 20).Value + Worksheets(MAIN).Cells(A, 20).Value
   TB(1) = Worksheets(MAIN).Cells(B, 15).Value + Worksheets(MAIN).Cells(A, 15).Value
   TB(2) = Worksheets(MAIN).Cells(B, 16).Value + Worksheets(MAIN).Cells(A, 16).Value
   TB(3) = Worksheets(MAIN).Cells(B, 17).Value + Worksheets(MAIN).Cells(A, 17).Value
   TB(4) = Worksheets(MAIN).Cells(B, 18).Value + Worksheets(MAIN).Cells(A, 18).Value
   TB(5) = Worksheets(MAIN).Cells(B, 19).Value + Worksheets(MAIN).Cells(A, 19).Value
   TB(6) = Worksheets(MAIN).Cells(B, 20).Value + Worksheets(MAIN).Cells(A, 20).Value
   Worksheets(MAIN).Cells(B, 15).Resize(, 6).Value = TB
  
   Sheets(MAIN).Select   '該当行のカット
   Range(Cells(A, 2), Cells(A, 4)).EntireRow.Delete
   A = A - 1
 
   Else
   

   End If

  Loop
Erase TB '静的配列の中身消去。

End Sub
0 hits

【68352】セルを比べて同じなら・・・ ののか 11/2/25(金) 15:54 質問
【68353】Re:セルを比べて同じなら・・・ Jaka 11/2/25(金) 16:36 発言
【68354】Re:セルを比べて同じなら・・・ ののか 11/2/25(金) 16:50 お礼
【68356】Re:セルを比べて同じなら・・・ Jaka 11/2/25(金) 17:16 発言
【68358】Re:セルを比べて同じなら・・・ ののか 11/2/25(金) 17:24 お礼
【68359】Re:セルを比べて同じなら・・・ SK63 11/2/25(金) 17:52 発言
【68355】Re:セルを比べて同じなら・・・ kanabun 11/2/25(金) 17:06 発言
【68357】Re:セルを比べて同じなら・・・ ののか 11/2/25(金) 17:23 お礼

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