FC2ブログ
上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。
「ひさびさにプログラム書いたなー、どっかにメモしないとわすれるなー」ってここに書くことに。
Blogをメモ代わりにしても、いいよね?

さて、本題。
Excelで複数のシートをひとつにまとめる必要が出てきたんだけどVLOOKUPとか使ってもいいんだけど単純にシートの内容をマージというか、「伝票にあたるシートの内容で台帳にあたるシートの内容を上書きしたい」という要望が出てきた。
例によって「人力マクロ」でいちいちやってたんだけど自動化するにあたってExcelVBAで実現することにした。
で、ある行をインデックスにして、インデックス行が特定の文字列になっているのをキー列にするんだけど、データの生成もとのせいでインデックス行の並びも含まれる項目も統一できてない。
「あ~、添え字に文字列していできりゃ楽なのにな~」という同僚の呟きがもれて、よし、それなら作ってしまえ、と。

シート1と2をマージするときはインデックスにする行にあるのは「単価」「個数」「販売先」みたいな文字列。
そのまま「Sheets("シート2").Cells(5,"単価")=Sheets("シート1").Cells(5,"単価")」見たいにはかけない。
”単価”っていう内容のセルがシート1は何番目、シート2は何番目、だからシート2の~とごにょごにょやらないけない。
つまりは「文字列を一意の数値に置き換えるメカニズム」になる。
単純に「文字列と列番号を紐付けた配列つくろう」っとなったけど、VBAだとちょっと面倒だった。

C#や、PHP、Rubyなんかには配列の添え字に直接文字列を書くことができる。

a = datas('売り上げ')

とか

a = datas["売り上げ"]

見たいに。
これとニアリーイコールなことを手軽にVBAでやりたいな、と。
しかも後々改修かかってもオヂサンに回ってこないような誰にでもわかるように・・・。

妥協を重ねて
a = Sheets("シート1").Cells(y, GetValue(配列1,"売り上げ"))
Sheets("シート2").Cells(y, GetValue(配列2,"売り上げ")) = a
のように使えるプロシージャを用意することに。

本当はB木でハッシュ関数なんか使ってキー値の大小比較を高速にするとか良いんだけど、バイナリサーチ+インサートソートという手抜きで実装した。
まだバグがのこってるけど、ひと段落ついたからメモ書きで残しておく。

Public Type 配列要素
  keys As Variant
  values As Variant
  index As Long
End Type

Public Function 配列作成() As 配列要素()
  Dim rtc() As 配列要素
  ReDim rtc(0)
  rtc(0).index = -1 ' 番兵
  配列作成 = rtc
End Function

Public Function 配列値設定(s() As 配列要素, key As Variant, val As Variant) As 配列要素()
  Dim cnt As Long
  Dim pos As Long
  Dim posMax As Long
  Dim posMin As Long
  Dim posMid As Long
  posMax = UBound(s)
  posMin = LBound(s)
  If s(posMin).index < 0 Then
    s(posMin).keys = key
    s(posMin).values = val
    s(posMin).index = posMin
    配列値設定 = s
    Exit Function
  Else
    Do While (posMax - posMin > 5)
      posMid = (posMin + posMax) / 2
      If (s(posMid).keys < key) Then
        posMin = posMid
      Else
        posMax = posMid
      End If
    Loop
    For pos = posMin To posMax
      If s(pos).keys = key Then
        s(pos).values = val
        配列値設定 = s
        Exit Function
      End If
    Next
  End If
  cnt = UBound(s) - LBound(s) + 1
  ReDim Preserve s(cnt)
  s(cnt).index = cnt
  s(cnt).keys = key
  s(cnt).values = val
  Call 配列ソート(s)
  配列値設定 = s
End Function

Private Function 配列ソート(s() As 配列要素) As 配列要素()
  Dim idx1 As Long
  Dim idx2 As Long
  Dim idx3 As Long
  Dim cnt As Long
  Dim t As 配列要素
  Dim looping As Boolean
  Dim posMax As Long
  Dim posMin As Long
  If (UBound(s) - LBound(s) <= 1) Then Exit Function
  For idx1 = UBound(s) To LBound(s) + 1 Step -1
    posMax = LBound(s)
    posMin = UBound(s)
    looping = False
    For idx2 = idx1 To LBound(s) + 1 Step -1
      idx3 = idx2 - 1
      If _
        ((IsNull(s(idx2).keys) Or Empty = s(idx2).keys) And (Not IsNull(s(idx3).keys) And Empty <> s(idx3).keys)) _
      Or _
        (s(idx2).keys < s(idx3).keys) _
      Then
        ' 大きくなくちゃいけないのがNULLかEMPTYのとき
        ' 入れ替える
        t = s(idx2)
        s(idx2) = s(idx3)
        s(idx3) = t
        looping = True
        If (posMin > idx2) Then posMin = idx2
        If (posMax < idx2) Then posMax = idx2
      End If
    Next
    If looping = False Then Exit For
  Next
End Function

Public Function 配列値取得(s() As 配列要素, key As Variant) As Variant
  Dim cnt As Long
  Dim pos As Long
  Dim posMax As Long
  Dim posMin As Long
  Dim posMid As Long
  posMin = LBound(s)
  posMax = UBound(s)
  posMax = UBound(s)
  posMin = LBound(s)
  Do While (posMax - posMin > 3)
    posMid = (posMin + posMax) / 2
    If (s(posMid).keys < key) Then
      posMin = posMid
    Else
      posMax = posMid
    End If
  Loop
  For posMid = posMin To posMax
    If s(posMid).keys = key Then
      配列値取得 = s(posMid).values
      Exit Function
    End If
  Next
End Function

Public Function 配列値最大値(s() As 配列要素)
  Dim x As Long
  Dim v As Variant
  For x = LBound(s) To UBound(s)
    If (s(x).index > 0) Then
      If Empty = v Then
        v = s(x).values
      Else
        If v < s(x).values Then v = s(x).values
      End If
    End If
  Next
  配列値最大値 = v
End Function

Public Function 配列値最小値(s() As 配列要素)
  Dim x As Long
  Dim v As Variant
  For x = LBound(s) To UBound(s)
    If (s(x).index > 0) Then
      If Empty = v Then
        v = s(x).values
      Else
        If v > s(x).values Then v = s(x).values
      End If
    End If
  Next
  配列値最小値 = v
End Function

Public Function シートマージ()
  Dim srcキー列() As 配列要素
  Dim dstキー列() As 配列要素
  Dim srcインデックス行() As 配列要素
  Dim dstインデックス行() As 配列要素
  Dim srcSheets As String
  Dim dstSheets As String
  Dim x1 As Long
  Dim y1 As Long
  Dim x2 As Long
  Dim y2 As Long
  Dim s1 As String
  Dim s2 As String
  Dim x As Long
  Dim y As Long
  Dim キー項目 As String
  Dim addX As Long
  Dim addY As Long
  キー項目 = "名称"
  srcSheets = "Sheet1"
  dstSheets = "Sheet2"
  srcキー列 = 配列作成()
  dstキー列 = 配列作成()
  srcインデックス行 = 配列作成()
  dstインデックス行 = 配列作成()
  x1 = 1
  s1 = Sheets(srcSheets).Cells(1, x1)
  Do While s1 <> ""
    Call 配列値設定(srcインデックス行, s1, x1)
    x1 = x1 + 1
    s1 = Sheets(srcSheets).Cells(1, x1)
  Loop
  x1 = 1
  s2 = Sheets(srcSheets).Cells(1, x1)
  Do While s2 <> ""
    Call 配列値設定(dstインデックス行, s2, x1)
    x1 = x1 + 1
    s2 = Sheets(srcSheets).Cells(1, x1)
  Loop
  y1 = 2
  x1 = 配列値取得(srcインデックス行, キー項目)
  x2 = 配列値取得(dstインデックス行, キー項目)
  s1 = Sheets(srcSheets).Cells(y1, x1)
  s2 = Sheets(dstSheets).Cells(y1, x2)
  Do While (s1 <> "") Or (s2 <> "")
    If (s1 <> "") Then Call 配列値設定(srcキー列, s1, y1)
    If (s2 <> "") Then Call 配列値設定(dstキー列, s2, y1)
    y1 = y1 + 1
    s1 = Sheets(srcSheets).Cells(y1, x1)
    s2 = Sheets(dstSheets).Cells(y1, x2)
    DoEvents
  Loop
  'インデックス行のすり合わせ
  For x = LBound(srcインデックス行) To UBound(srcインデックス行)
    If (Empty = 配列値取得(dstインデックス行, srcインデックス行(x).keys)) Then
      ' ここにインデックス追加処理
      If Not Empty = 配列値最大値(dstインデックス行) Then
        addX = 1 + 配列値最大値(dstインデックス行)
        Call 配列値設定(dstインデックス行, srcインデックス行(x).keys, addX)
        Sheets(dstSheets).Cells(1, addX) = srcインデックス行(x).keys
      End If
      Debug.Print ""
    End If
  Next
  For y = LBound(srcキー列) To UBound(srcキー列)
    If Not IsNull(srcキー列(y).keys) And Empty <> srcキー列(y).keys Then
      If (Empty = 配列値取得(dstキー列, srcキー列(y).keys)) Then
        'ここにキー追加処理
        If Not Empty = 配列値最大値(dstキー列) Then
          addY = 配列値最大値(dstキー列) + 1
        Else
          addY = 1
          Do While Sheets(dstSheets).Cells(addY, 1) <> ""
            addY = addY + 1
          Loop
        End If
        Call 配列値設定(dstキー列, srcキー列(y).keys, addY)
        Sheets(dstSheets).Cells(addY, 1) = srcキー列(y).keys
        Debug.Print ""
      End If
      For x = LBound(srcインデックス行) To UBound(srcインデックス行)
        DoEvents
        If Not IsNull(srcインデックス行(x).keys) And Empty <> srcインデックス行(x).keys Then
          s1 = Sheets(srcSheets).Cells(srcキー列(y).values, srcインデックス行(x).values)
          If s1 <> キー項目 And s1 <> "" Then
            x2 = 配列値取得(dstインデックス行, srcインデックス行(x).keys)
            y2 = 配列値取得(dstキー列, srcキー列(y).keys)
            If Sheets(dstSheets).Cells(y2, x2) <> s1 Then
              Sheets(dstSheets).Select
              Sheets(dstSheets).Cells(y2, x2).Select
              Sheets(dstSheets).Cells(y2, x2).Font.Color = RGB(255, 0, 0)
              Sheets(dstSheets).Cells(y2, x2) = s1
            End If
          End If
        End If
      Next
    End If
  Next
End Function
スポンサーサイト
上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。