Excel VBA質問箱 IV

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

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


17128 / 76738 ←次へ | 前へ→

【65067】Re:転記のVBAを教えてください。
回答  Hirofumi  - 10/4/10(土) 23:57 -

引用なし
パスワード
   こんな事で善いのかな?
理解して居なかったらごめん

Option Explicit

Public Sub Main()

  '画面更新を停止
  Application.ScreenUpdating = False
  
  '1シート分処理
  Transfer ActiveSheet.Range("A5:T13"), Worksheets("H22").Range("A1")

  '画面更新を再開
  Application.ScreenUpdating = True
  
  MsgBox "処理が完了しました", vbInformation
     
End Sub

Private Sub Transfer(rngList As Range, rngResult As Range)

  '1品目の行数
  Const clngPitch As Long = 3
  
  Dim i As Long
  Dim j As Long
  Dim k As Long
  Dim l As Long
  Dim m As Long
  Dim lngRows As Long
  Dim vntResult1 As Variant
  Dim vntResult2 As Variant
  Dim vntData As Variant

  '結果シートに就いて
  With rngResult
    '最終行の取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      lngRows = 0
    End If
  End With
  
  'List範囲に就いて
  With rngList
    '年月日、店舗名を配列に取得
    vntResult1 = .Cells(1, 1).Offset(-3).Resize(, 2).Value
    'データ列が偶数であるのを確認し、奇数なら1列増やして偶数にし配列に取得
    If .Columns.Count Mod 2 = 0 Then
      'データを配列に取得
      vntData = .Value
    Else
      vntData = .Resize(, .Columns.Count + 1).Value
    End If
  End With
  
  '結果用配列を確保
  ReDim vntResult2(1 To UBound(vntData, 1) * UBound(vntData, 2))
  
  'データを結果用配列に転記
  For i = 1 To UBound(vntData, 2) Step 2 '2列づつ処理
    For j = 1 To UBound(vntData, 1) Step 3 '3行づつ処理
      For k = 0 To 1 '奇数列、偶数列を処理
        For l = 0 To 2 '品名、個数、金額を処理
          m = m + 1
          vntResult2(m) = vntData(j + l, i + k)
        Next l
      Next k
    Next j
  Next i
  
  'データを出力
  With rngResult
    .Offset(lngRows + 1).Resize(, UBound(vntResult1, 2)).Value = vntResult1
    .Offset(lngRows + 1, UBound(vntResult1, 2)) _
        .Resize(, UBound(vntResult2)).Value = vntResult2
  End With
  
  'データを消去
'  With rngList
'    .Cells(1, 1).Offset(-3).Resize(, 2).ClearContents
'    .ClearContents
'  End With
  
End Sub

0 hits

【65058】転記のVBAを教えてください。 八家九僧陀 10/4/9(金) 18:31 質問
【65059】Re:転記のVBAを教えてください。 Hirofumi 10/4/10(土) 5:47 発言
【65060】Re:転記のVBAを教えてください。 八家九僧陀 10/4/10(土) 19:11 回答
【65061】Re:転記のVBAを教えてください。 八家九僧陀 10/4/10(土) 19:14 回答
【65067】Re:転記のVBAを教えてください。 Hirofumi 10/4/10(土) 23:57 回答

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