Excel VBA質問箱 IV

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

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


14575 / 76734 ←次へ | 前へ→

【67648】Re:2つのファイル間でのコピー&ペースト
回答  Hirofumi  - 10/12/20(月) 23:44 -

引用なし
パスワード
   こんなのでは

Option Explicit
Option Compare Text

Public Sub Main()

  Dim i As Long
  Dim wkbFrom As Workbook
  Dim wkbTo As Workbook
  Dim vntFrom As Variant
  Dim vntTo As Variant
  
  '経費計画Bookのシート名を列挙
  vntFrom = Array("東京支店", "横浜支店")
  '経費実績Bookのシート名を列挙
  vntTo = Array("東京支店", "横浜支店")
  
  Set wkbFrom = Workbooks("経費計画.xls")
  Set wkbTo = Workbooks("経費計画.xls")
  
  Application.ScreenUpdating = False
  
  For i = 0 To UBound(vntFrom)
    Post wkbFrom.Worksheets(vntFrom(i)).Range("A1"), _
          wkbTo.Worksheets(vntTo(i)).Range("A1")
  Next i
  
  Application.ScreenUpdating = True
  
  Set wkbFrom = Nothing
  Set wkbTo = Nothing
  
  MsgBox "処理が完了しました", vbInformation
  
End Sub

Private Sub Post(rngFrom As Range, rngTo As Range)

  '経費実績の列数(A〜B列)
  Const clngColumns1 As Long = 2
  '経費実績の中のKeyと成る列位置(基準列からのA列の列Offset:0列目)
  Const clngKey1 As Long = 0
  '転記先先頭列位置(基準列からのB列の列Offset:1列目)
  Const clngItem1 As Long = 1
  
  '経費計画の列数(A〜B列)
  Const clngColumns2 As Long = 2
  '経費計画の中のKeyと成る列位置(基準列からのA列の列Offset:0列目)
  Const clngKey2 As Long = 0
  '転記元先頭列位置(基準列からのQ列の列Offset:1列目)
  Const clngItem2 As Long = 1

  Dim i As Long
  Dim j As Long
  Dim lngRows1 As Long, lngRows2 As Long
  Dim vntKeys1() As Variant, vntKeys2() As Variant
  Dim vntData1() As Variant, vntData2() As Variant
  Dim rngResult As Range
  Dim lngStart As Long
  
  With rngTo
    '行数の取得
    lngRows1 = .Offset(Rows.Count - .Row, clngKey1).End(xlUp).Row - .Row + 1
    If lngRows1 <= 1 And .Value = "" Then
      Exit Sub
    End If
    '復帰用Keyを設定
    .Offset(, clngColumns1).EntireColumn.Insert
    With .Offset(, clngColumns1)
      .Value = 1
      .Resize(lngRows1).DataSeries Rowcol:=xlColumns, _
          Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
    End With
    'A列をKeyとして整列
    .Resize(lngRows1, clngColumns1 + 1).Sort _
        Key1:=.Offset(, clngKey1), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    'Key列データを配列に取得
    vntKeys1 = .Offset(, clngKey1).Resize(lngRows1 + 1).Value
  End With
  '結果用配列を確保
  ReDim vntData1(1 To lngRows1, 1 To 1)
  
  With rngFrom
    '行数の取得
    lngRows2 = .Offset(Rows.Count - .Row, clngKey2).End(xlUp).Row - .Row + 1
    If lngRows2 <= 1 And .Value = "" Then
      Exit Sub
    End If
    '復帰用Keyを設定
    .Offset(, clngColumns2).EntireColumn.Insert
    With .Offset(, clngColumns2)
      .Value = 1
      .Resize(lngRows2).DataSeries Rowcol:=xlColumns, _
          Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
    End With
    'L列をKeyとして整列
    .Resize(lngRows2, clngColumns2 + 1).Sort _
        Key1:=.Offset(, clngKey2), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    'Key列データを配列に取得
    vntKeys2 = .Offset(, clngKey2).Resize(lngRows2 + 1).Value
    '転記データを配列として取得
    vntData2 = .Offset(, clngItem2).Resize(lngRows2).Value
  End With
  
  '経費実績を検索して見つかったその行を経費実績の「抽出データ」を転記
  lngStart = 1
  For i = 1 To lngRows1
    For j = lngStart To lngRows2
      ''経費実績のKeyが経費計画のKeyより大きければ
      If vntKeys1(i, 1) < vntKeys2(j, 1) Then
        'Forを抜ける
        Exit For
      Else
        '経費実績のKeyと経費計画のKey等しければ
        If vntKeys1(i, 1) = vntKeys2(j, 1) Then
          '出力用配列に転記
          vntData1(i, 1) = vntData2(j, 1)
          Exit For
        End If
      End If
    Next j
    If j <= lngRows1 Then
      lngStart = j
    Else
      Exit For
    End If
  Next i
  
  '結果を出力
  With rngTo
    .Offset(, clngItem1).Resize(lngRows1, 2).Value = vntData1
    '作業列をKeyとして整列
    .Resize(lngRows1, clngColumns1 + 1).Sort _
        Key1:=.Offset(, clngColumns1), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    '作業列を削除
    .Offset(, clngColumns1).EntireColumn.Delete
  End With
  
  With rngFrom
    '作業列をKeyとして整列
    .Resize(lngRows2, clngColumns2 + 1).Sort _
        Key1:=.Offset(, clngColumns2), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    '作業列を削除
    .Offset(, clngColumns2).EntireColumn.Delete
  End With
    
End Sub

2 hits

【67644】2つのファイル間でのコピー&ペースト さや 10/12/20(月) 22:22 質問
【67648】Re:2つのファイル間でのコピー&ペースト Hirofumi 10/12/20(月) 23:44 回答
【67649】Re:2つのファイル間でのコピー&ペースト さや 10/12/21(火) 6:43 お礼
【67654】Re:2つのファイル間でのコピー&ペースト Jaka 10/12/21(火) 10:53 発言

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