スポンサーサイト 


上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

Excel VBA をやってみた その14 


何故だろう・・・ 質問者さんが質問を削除した。
他回答者さんも失礼な振る舞いをしていたとも思えない。
せっかくなので、ここで紹介・解説してみる

質問の内容は、

Sheet1の列Aの1行目から列XA200行目まで
すべての各セルに 22,22,45 のようにカンマで区切られた塊が書かれている。
このセル同士をひとつずつ順番にA列の1行目のセルにかいてあるものを基準にして比較していき、
もし同じ内容のセルがあった場合は、例えば、A1 と B2 が同じだったら「A列1行目とB列2行目」と
A列の300行目から文字として書き起こしていきます。
基準にするセルを変えながら参照し、比較し同じものを探すコードを教えてください。

というものに、以下を初期回答したのですが・・・
(初期回答というのは、この後、性能向上版を提示する為に回答削除・回答し直ししてました)

以下でどうでしょう
10秒もあれば終わると思います。
(試したデータでは5秒くらいでしたが・・・(最終行:15078))

Public Sub Samp1()
  Dim dic As Object, dicW As Object
  Dim vA As Variant, v As Variant, vv As Variant
  Dim sS As String
  Dim i As Long, j As Long

  Application.ScreenUpdating = False
  Set dic = CreateObject("Scripting.Dictionary")
  Set dicW = CreateObject("Scripting.Dictionary")
  vA = Range("A1:XA200").Value
  For j = 1 To UBound(vA, 2)
    For i = 1 To UBound(vA)
      sS = dicW(vA(i, j))
      If (Len(sS) > 0) Then
        If (dic.Exists(vA(i, j))) Then
          sS = dic(vA(i, j))
        Else
          v = Split(sS, "_")
          v(2) = Split(Cells(1, Int(v(1))).Address, "$")(1)
          sS = Join(v, "_")
        End If
        dic(vA(i, j)) = sS & "," _
          & i & "_" & j & "_" & Split(Cells(1, j).Address, "$")(1)
      Else
        dicW(vA(i, j)) = i & "_" & j & "_"
      End If
    Next
  Next

  If (dic.Count > 0) Then
    i = 0
    With Range("A300")
      For Each vA In dic.Items
        v = Split(vA, ",")
        ReDim vv(UBound(v))
        For j = 0 To UBound(v)
          vv(j) = Split(v(j), "_")
        Next
        For j = 1 To UBound(vv)
          sS = vv(0)(2) & " 列 " & vv(0)(0) & " 行目と " _
            & vv(j)(2) & " 列 " & vv(j)(0) & " 行目"
          .Offset(i).Resize(, 3) = _
            Array(sS, vv(0)(0), vv(0)(1))
          i = i + 1
        Next
      Next
      With .Resize(i, 3)
        .Sort .Cells(3), xlAscending, .Cells(2), Header:=xlNo
        .Offset(, 1).Resize(, 2).ClearContents
      End With
    End With
  End If
  Set dic = Nothing
  Set dicW = Nothing
  Application.ScreenUpdating = True
End Sub


※ テスト用データは以下で作成していました

Public Sub test()
  Dim r As Range
  Dim sS As String
  Dim i As Long

  Randomize
  Application.ScreenUpdating = False
  For Each r In Range("A1:XA200")
    sS = ""
    For i = 1 To 3
      sS = sS & "," & Int(78 * Rnd()) + 22
    Next
    r = Mid(sS, 2)
  Next
  Columns.AutoFit
  Application.ScreenUpdating = True
End Sub


そんなにヘンテコな記述じゃないと思うのですが・・・
まぁ、コメントも入れていないので、以降解説していきます。

※ 後半には、質問者さんは何か・・・ Find を使った方法を求めていた??? みたいなので
Find を使った記述にも触れています。
続きを読んでみようかな ---≫
スポンサーサイト

2015/01/01

Category: 解説か

TB: --  /  CM: 0

top △

Excel VBA をやってみた その13 


副題:長さの種類の組み合わせ

組合せ合計値の検索は、過去記事「Excel VBA をやってみた その11」とか・・・
そこから色々な記事に飛べますね

今回は、長さの種類の組み合わせ・・・ということで、

全長:5200mm の棒を効率よく切っていきたい
切る長さは 520mm / 580mm / 730mm / 980mm / 1030mm / 1240mm の6種類
端材は 50mm ・・・ (おそらくは、切りしろを加味した長さ?)
なので、各種類を加算して 5150mm に近いもののパターン求めたい

考え方として、
各種類が 5150mm で何本取れるか・・・で
520mm なら9本取れるので、520 / 520 / ・・・ / 520 の9つのデータに展開して・・・
他の種類についても、同様にデータ展開して・・・ 
組合せ合計値の検索を使って求める・・・ でも良いかもしれない・・・???

でも、せっかくなので・・・
各種類を何本使っているかの管理でやってみようか・・・

で、回答してみたのが以下です・・・
黄色い表示の部分・・・ これ、処理を見なおして修正しています(後述 Samp2 として)
現状のままでも、実害はないのですが・・・

参考程度で

以下を実行すると、添付図のような結果が表示されます。
上書きする場合は、2行2列余計にクリアしてから出力します。

Public Sub Samp1()
  Dim dic As Object
  Dim vA As Variant, v As Variant
  Dim iA() As Long
  Dim iClen As Long, iPos As Long
  Dim sS As String
  Dim i As Long, j As Long
  Const CMAXLEN As Long = 5200 ' 全長
  Const CREMLEN As Long = 50 ' 残す
  Const COKLEN As Long = 30 ' 許容差

  vA = Array(520, 580, 730, 980, 1030, 1240, CMAXLEN)
  ReDim iA(UBound(vA))
  Set dic = CreateObject("Scripting.Dictionary")

  iClen = CMAXLEN - CREMLEN
  iPos = 0
  Do While ((0 <= iPos) And (iPos <= UBound(vA)))
    If (iClen >= vA(iPos)) Then
      iClen = iClen - vA(iPos)
      iA(iPos) = iA(iPos) + 1
    ElseIf (iClen <= COKLEN) Then
      sS = iClen + CREMLEN
      For i = 0 To UBound(iA)
        sS = sS & ","
        If (iA(i) <> 0) Then sS = sS & iA(i)
      Next
      dic(dic.Count) = sS
      iClen = iClen + vA(iPos)
      iA(iPos) = iA(iPos) - 1
      iPos = iPos + 1
    Else
      Do While (iPos >= 0)
        If (iA(iPos) <> 0) Then
          iClen = iClen + vA(iPos)
          iA(iPos) = iA(iPos) - 1
          iPos = iPos + 1
          If (iClen >= vA(iPos)) Then Exit Do
        Else
          iPos = iPos - 1
        End If

      Loop
    End If
  Loop

  If (dic.Count > 0) Then
    With Range("A1")
      .Resize(dic.Count + 3, UBound(vA) + 3).Clear
      .Value = "残 mm"
      With .Offset(, 1).Resize(, UBound(vA))
        .Value = vA
        .NumberFormatLocal = "0 ""mm"""
      End With
      With .Offset(1).Resize(dic.Count)
        .Value = WorksheetFunction.Transpose(dic.Items)
        .TextToColumns .Cells(1), xlDelimited, Comma:=True
        With .Resize(, UBound(vA) + 1)
          .Sort .Cells(1), xlAscending, Header:=xlNo
          With .Offset(, 1).Resize(, .Columns.Count - 1)
            .NumberFormatLocal = "0 ""本"""
          End With
        End With
      End With
    End With
  End If
  Set dic = Nothing
End Sub

厳密に記述すると

>     For i = 0 To UBound(iA)
部分は
     For i = 0 To UBound(iA) - 1
と・・・
すべきかと・・・・

出力結果の範囲+2行2列をクリアしてから書き出しするので、1列分余計に空白のデータを作っていても実害はない・・・かな?


結果として表示されるのは、以下のようになります。
(修正した Samp2 の表示も同じです)

kEnt206Samp1.jpg

上記記述では、
  vA = Array(520, 580, 730, 980, 1030, 1240, CMAXLEN)
部分を変更することで、表示が変わるようになっています。
ただ、記述する順は昇順になるように・・・ これ、暗黙であります。
また、1番短いものは、許容差(COKLEN)より大きい事・・・ これも、暗黙であります。
さて、次に用意した Samp3 では、
  vA = Array(350, 480, 520, 580, 680, 730, 880, 980, 1030, 1170, 1240, CMAXLEN + 1)
に変更して、結果表示部分に色気を出して・・・ 以下の様な感じに

kEnt206Samp3.jpg

A列の「使用 mm」部分は、検算も兼ねて、1行目の mm と求めた本数とを SUMPRODUCT
「本数」部分には SUM、「種類数」部分には COUNT
を設定しています。

使っていくうちに、データが変わった・・・ さて、VBA 部分を書き換えるのも面倒・・・
という事で、Samp3 をシートに設定したデータで動くようにしたのが Samp4 と Sheet1

kEnt206Sheet1.jpg  kEnt206Samp4.jpg

せっかくなので、最低必要数も与えて・・・ Samp4 を元に変更したのが Samp5 と Sheet2

kEnt206Sheet2.jpg  kEnt206Samp5.jpg

kEnt206Sheet2_2.jpg  kEnt206Samp5_2.jpg

kEnt206Sheet2_3.jpg  kEnt206Samp5_3.jpg

※ シート上「サイズ」を入力する枠は10個分の所にしていますが、実際には意味ありません。
 C6 ~ その行の右端のものまでを対象にしています。
続きを読んでみようかな ---≫

2014/11/28

Category: 解説か

TB: --  /  CM: 0

top △

CSV ファイルの取り込み 


以下の様な質問があって回答したわけですが・・・

CSV ファイルが2つあり、

1つ目「hoge1.csv」
aaa,bbb,ccc,ddd
1,2,3,4

2つ目「hoge2.csv」
aaa,bbb,ddd,eee,fff
1,2,4,5,6

これを1つのテーブルに取り込んで以下の様にしたい
 aaa  bbb  ccc  ddd  eee  fff 
 1  2  3  4     
 1  2    4  5  6 

で、回答したものは

他にも流用できそうなものを作ってみました。

CSV ファイルが「hoge1.csv」「hoge2.csv」だけであれば、
以下の2行を変更することで動くと思います。

  Const CPATH = "D:\HogeHoge\tmp\" ' CSV ファイルまでのパス
  Const CTBL = "テーブル名" ' 作成テーブル名

その他に処理する CSV ファイルがあるのなら、

  For Each vDp In Array("hoge1.csv", "hoge2.csv")

部分を変更すれば動くと思います。
また、
毎回テーブルを作り直していますが、処理に合わせて変更してください。

なお、細かいエラー処理は入れてません。


標準モジュールに記述後、実行するのは以下

Public Sub test()
  Dim dic As Object, dicW As Object
  Dim oFso As Object
  Dim sBuf As String
  Dim vDp As Variant, vDc As Variant, v As Variant
  Dim vAry As Variant
  Dim i As Long, j As Long
  Dim sSql As String
  Const CPATH = "D:\HogeHoge\tmp\" ' CSV ファイルまでのパス
  Const CTBL = "テーブル名" ' 作成テーブル名
  Const CSQL = "INSERT INTO {%1}({%2}) " _
    & "SELECT {%2} FROM [{%3}] IN '{%4}'[text;FMT=Delimited;HDR=YES;IMEX=1];"

  ' 各 CSV の項目部分の入手
  Set dic = CreateObject("Scripting.Dictionary")
  Set oFso = CreateObject("Scripting.FileSystemObject")
  For Each vDp In Array("hoge1.csv", "hoge2.csv")
    With oFso.OpenTextFile(CPATH & vDp)
      sBuf = .ReadLine
      dic.Add vDp, CreateObject("Scripting.Dictionary")
      For Each vDc In Split(Replace(sBuf, """", ""), ",")
        dic(vDp)(Trim(vDc)) = Null
      Next
      .Close
    End With
  Next
  Set oFso = Nothing

  ' 項目の重複排除と昇順並び替え
  Set dicW = CreateObject("Scripting.Dictionary")
  For Each vDp In dic.Keys
    For Each vDc In dic(vDp).Keys
      dicW(vDc) = Null
    Next
  Next
  vAry = dicW.Keys
  Set dicW = Nothing
  For i = 0 To UBound(vAry) - 1
    For j = i + 1 To UBound(vAry)
      If (vAry(i) > vAry(j)) Then
        v = vAry(i)
        vAry(i) = vAry(j)
        vAry(j) = v
      End If
    Next
  Next

  ' テーブルの作り直し:オートナンバ「an」を付加し、各項目を長整数で作成
  sSql = "DROP TABLE " & CTBL & ";"
  On Error Resume Next
  CurrentDb.Execute sSql
  On Error GoTo 0
  sSql = "CREATE TABLE " & CTBL & "( an AUTOINCREMENT"
  For Each v In vAry
    sSql = sSql & ", [" & v & "] LONG"
  Next
  sSql = sSql & ");"
  CurrentDb.Execute sSql
  RefreshDatabaseWindow

  ' CSV からテーブルへの読み込み
  For Each vDp In dic.Keys
    sSql = CSQL
    sSql = Replace(sSql, "{%1}", CTBL)
    sSql = Replace(sSql, "{%2}", "[" & Join(dic(vDp).Keys, "], [") & "]")
    sSql = Replace(sSql, "{%3}", vDp)
    sSql = Replace(sSql, "{%4}", CPATH)
    CurrentDb.Execute sSql
  Next
  Set dic = Nothing
End Sub


過去記事を読まれていた方ならわかると思いますが、
・Dictionary の2段構成で、各CSVファイルの項目を管理してます
1段目のキー:ファイル名、2段目のキー:項目名(フィールド名)
・・・ですが、1ファイル内で項目が重複する事はないと思うので過剰仕様と思います。

また、CSV から読み込む部分は
  ' CSV からテーブルへの読み込み
  For Each vDp In dic.Keys
    DoCmd.TransferText acImportDelim, , CTBL, CPATH & vDp, True
  Next
の1行で済ませる事が出来ますけど・・・
・・・けど、回答にあるやり方を覚えておくと、いろいろと細工がしやすくなるのかな ???
続きを読んでみようかな ---≫

2014/03/27

Category: 解説か

TB: --  /  CM: 0

top △

イベント処理記述の変形 


先の記事「Excel ファイルのプレビュー」で、
コマンドボタン「btnC1」(標題:左)、「btnC2」(標題:右)のクリック時に 5列動かすために以下を記述していました。

Private Sub btnC1_Click()
  Dim i As Long

  i = iShowCol
  iShowCol = iShowCol - 5
  If (iShowCol < 0) Then iShowCol = 0
  If (i <> iShowCol) Then Call ExcelScreenShow(False)
End Sub

Private Sub btnC2_Click()
  Dim i As Long

  i = iShowCol
  iShowCol = iShowCol + 5
  If (iShowCol > UBound(vBuff, 2) - 10) Then iShowCol = UBound(vBuff, 2) - 10
  If (i <> iShowCol) Then Call ExcelScreenShow(False)
End Sub

何をやっているか・・・ チョッと説明してみると
iShowCol は、読み込んだ Excel データ vBuff(1 to 50, 1 to 50) を、
列方向にどの程度移動させた状態で 10 列表示させましょうか・・・ というもの
つまり、iShowCol の取りうる値の範囲は 0 ≦ iShowCol ≦ 40 となります。(10 列は表示するので)
で、btnC1 がクリックされたら -5 列、btnC2 がクリックされたら +5 列して・・・
範囲を外れたら限界値に設定して、前と同じ値だったら、移動させた表示は不要だから抜ける・・・

まっ、これはこれで動いているんですけど・・・ 動いているけど、この記述は・・・ ブーブー
Private Sub btnC1_Click()
  Dim i As Long

  i = iShowCol
  i = i - 5
  If (i < 0) Then i = 0
  If (iShowCol <> i) Then
    iShowCol = i
    Call ExcelScreenShow(False)
  End If
End Sub
少なくとも上記の様にするとか
Private Sub btnC1_Click()
  If (iShowCol = 0) Then Exit Sub
  iShowCol = iShowCol - 5
  Call ExcelScreenShow(False)
End Sub
の様にすれば良いんじゃ・・・ 異論はありません。
記述している環境・状況によって変化させていけば良いと思います。

今回は、書き方ではなく、考え方を変化・変形していきます。
続きを読んでみようかな ---≫

2013/09/19

Category: 解説か

TB: --  /  CM: 0

top △

再帰処理にはまる(その6) 


テーブル名「T9」
フィールド:顧客番号(テキスト)/ 売上金額(通貨) / 売上月(テキスト)
an顧客番号売上金額売上月
1001¥100 1月
2002¥50 1月
3003¥200 1月
4004¥150 1月

テーブル名「T9A」
フィールド:顧客番号(テキスト)/ 集約先番号(テキスト)
an顧客番号集約先番号
1001002
2002003

上記2つのテーブルから以下の結果を導きたい
集約番号売上金額計売上月
003¥350 1月
004¥150 1月

標準モジュールに以下を記述しておきます。
Public Function Bango(sSrc As String) As String
  Dim rs As New ADODB.Recordset
  Dim sR As String

  sR = sSrc
  rs.Source = "SELECT * FROM T9A WHERE 顧客番号='" & sSrc & "';"
  rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  If (Not rs.EOF) Then sR = Bango(rs("集約先番号"))
  rs.Close
  Bango = sR
End Function

クエリの SQL ビューで以下を記述します。
SELECT Bango(顧客番号) AS 集約番号, Sum(売上金額) AS 売上金額計, 売上月
FROM T9
GROUP BY Bango(顧客番号), 売上月;

というのを回答したわけですが・・・・
続きを読んでみようかな ---≫

2013/05/21

Category: 解説か

TB: --  /  CM: 0

top △


上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。