エクセルデータをシステムインポートデータの形式に変更したい

Question

こんにちは。
仕事で伝票を管理しているエクセルデータを管理ソフトに一括でインポートするため、管理ソフト用のデータ作成をしようとしています。

図のように伝票番号ごとに（色分けごとが1枚の伝票）管理しています。
これを管理ソフトインストール用にするには、1枚の伝票に使用した「桁数」が必要で、更に伝票の最後に１行増え、品名の欄に「伝票番号」がきます。

関数で何とかしようとやり始めましたが、お手上げになりました。

伝票の枚数が多いので、時間短縮できるよう、やり方を教えてくださる方のお力をお借りできるとありがたいです。
お手数をおかけしますが、よろしくお願いいたします。

WindFaller · Accepted Answer

①　注意：対応表がないと、このマクロは動きません。

Sub ChangeFormatsTIO()
'すでに伝票番号はソートが終わっているものとします。
　Dim LastRow As Long
　Dim sh1 As Worksheet
　Dim sh2 As Worksheet
　Dim shTio As Worksheet
　Dim out_Order, out_O
　Dim out_title, Ttl
　Dim i As Long, k, j As Long
　Dim Keta As Long
　Dim Dnp As Long
　Dim Out_dnp As Variant
　'********設定項目*******
　'シート名
　Set sh1 = Worksheets("Sheet1")　'元のデータ
　Set sh2 = Worksheets("Sheet2")　'排出されるデータ
　Set shTio = Worksheets("対応表1")

　'出力の項目の取得
　With shTio
　　out_title = .Range("C2", .Cells(Rows.Count, 3).End(xlUp)).Value
　　Ttl = Application.Transpose(out_title)
　　
　　out_Order = .Range("B2", .Cells(Rows.Count, 2).End(xlUp)).Value '順番リスト
　　out_Order = Application.Transpose(out_Order)
　　For Each c In .Range("A1", .Cells(1, Columns.Count).End(xlToLeft))
　　　If c.Column = 2 Then
　　　　For i = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
　　　　　If Not IsNumeric(c.Offset(i).Value) Then
　　　　　　Dnp = i　'伝票番号出力位置
　　　　　　Exit For
　　　　　End If
　　　　Next
　　　ElseIf c.Value Like "*出力*" Then
　　　　For i = 1 To .Cells(Rows.Count, 3).End(xlUp).Row　'C列
　　　　　If c.Offset(i).Value <> "" Then
　　　　　　Out_dnp = i　'伝票番号出力位置
　　　　　　Exit For
　　　　　End If
　　　　Next
　　　ElseIf c.Value Like "桁*" Then
　　　　For i = 1 To .Cells(Rows.Count, 3).End(xlUp).Row　'C列
　　　　　If c.Offset(i).Value <> "" Then
　　　　　　Keta = i　 '桁番号
　　　　　　Exit For
　　　　　End If
　　　　Next
　　　End If
　　Next
　End With

　i = 1
　y = 2
　With sh1
　　col = .Range("A1", .Cells(1, Columns.Count).End(xlToLeft)).Columns.Count
　　Data1 = .Range("A1", .Cells(Rows.Count, 1).End(xlUp).Resize(, col).Offset(1)).Value
　End With
　With sh2
　　'前の転送済のデータの消去
　　.Range("A1").CurrentRegion.ClearContents
　　.Range("A1").Resize(, UBound(Ttl)).Value = Ttl

　　Do
　　　i = i + 1
　　　j = 1
　　　For Each k In out_Order
　　　　If IsNumeric(k) And Not IsEmpty(k) Then
　　　　　.Cells(i, k).Value = Data1(y, j)
　　　　ElseIf VarType(k) = vbString Then
　　　　　cnt = cnt + 1
　　　　　.Cells(i, Keta).Value = cnt
　　　　End If
　　　　j = j + 1
　　　　
　　　Next k

　　　If Data1(y + 1, Dnp) <> Data1(y, Dnp) And i > 2 Then
　　　　i = i + 1
　　　　j = 1
　　　　'桁番号
　　　　cnt = cnt + 1
　　　　For Each k In out_Order
　　　　　If IsNumeric(k) And Not IsEmpty(k) Then
　　　　　　If k < Out_dnp Then
　　　　　　　.Cells(i, k).Value = Data1(y, j)　'日付
　　　　　　ElseIf k > Out_dnp Then
　　　　　　　 .Cells(i, k).Value = 0
　　　　　　End If
　　　　　Else
　　　　　　.Cells(i, Keta).Value = cnt
　　　　　End If
　　　　j = j + 1
　　　Next
　　　.Cells(i, Out_dnp).Value = Data1(y, Dnp) '伝票番号
　　　cnt = 0
　　End If
　　y = y + 1
　　DoEvents
　Loop Until y = UBound(Data1)
End With
End Sub
'

WindFaller · Answer

こんにちは。

今回は、偶然が重なったにすぎないと思いますが、ちょっと難しい話を残しておきます。

それは、会社の中で偉い人になった時に、いえ、もう直面しているかもしれませんが、
『日本版SOX法』という企業内の実務で使われるExcelなどの使用手順などの統制のことです。『Excelレガシー』といって、担当者がいなくなると、とたんに表計算ソフトが使えなくなって、事業に支障を来すことになる問題です。

特に、担当者だけが分かっている独特のメソッドなどが災いするそうです。まして、今、Excel自体も過渡期にあるようで、人知れず使えなくなっている機能もあったりします。そこにマクロの内容が関わってしまうと、専門の人しか直せません。

今回、ある程度、汎用性を高めることを念頭には入れて作りましたが、このように図に当るというのは、みけみけ丸さんの理解あっての賜物に違いありません。

ただ、今回のマクロについては、本当は、半年後とかに、もう一度精査したほうがよいかもしれません。会社で使うマクロは、月度末、年度末を経て信頼のおけるツールに変わります。

私としては、できるだけ、Sheet1側の項目の順序とSheet2側の項目の順序の間は飛んでも、順序は逆にならない方が安定して処理できると思います。

以下は、専門業者のページですが、『Excelレガシー問題』に対して、とても参考にしています。

5.Excel（エクセル）レガシー問題
http://www.ai-light.com/access/gigyho_access_legacy.html

何か、私としても、気持ちの良い終わり方ができそうな気がします。
私の方からも、お礼を申し上げます。

WindFaller · Answer

ご指摘の部分は、もともと、手元のコードでは「？」のついていたところで、どうするか反応を危ぶんでいた部分です。

ただ、それは、伝票番号と桁番号の間ということと、その間のSheet1 の順番が逆順になっている部分がありませんから、特に問題はないと思います。

　　'桁番号
　　cnt = cnt + 1
　　For Each k In out_Order
　　　If IsNumeric(k) And Not IsEmpty(k) Then
　　　　If k < Out_dnp Then
　　　　　.Cells(i, k).Value = Data1(y, j)　'日付
　　　　'-----------------------------'以下2行の訂正
　　　　ElseIf k > Out_dnp And Keta > k Then
　　　　　　 .Cells(i, k).Value = Data1(y, j)
　　　　End If
　　　Else
　　　　.Cells(i, Keta).Value = cnt
　　　End If
　　j = j + 1
　Next

'------------------
ElseIf k > Out_dnp And Keta > k Then
伝票番号より大きく、桁番号よりも小さい間という意味

しかし、明細区分の後がどのようになっているのが良いのか、分かっていません。
こういうことも考えられます。

　　'桁番号
　　　　cnt = cnt + 1
　　　　For Each k In out_Order
　　　　　If IsNumeric(k) And Not IsEmpty(k) Then
　　　　　　If k < Out_dnp Then
　　　　　　　.Cells(i, k).Value = Data1(y, j)　'日付
　　　　　　ElseIf k > Out_dnp And Keta > k Then
　　　　　　　 .Cells(i, k).Value = Data1(y, j)
　　　　　　ElseIf k > Keta Then
　　　　　　　 .Cells(i, k).Value = 0 　'0を入れる
　　　　　　End If
　　　　　Else
　　　　　　.Cells(i, Keta).Value = cnt
　　　　　End If
　　　　j = j + 1
　　　Next

そのループの中で処理した方が収まるとは思うものの、もしかしたら、その塊全体を直したほうがよいのかもしれません。

それにしても、今回、詳しい説明をしていませんでしたが、仕様変更にもかかわらず、よく設定・実行ができたことに、かなり驚きました。実は、半信半疑だったのです。このレベルになると設定が分からないという人も出てきます。

なお、
>これが最後だと思いますので、
すでに私自身が、ここで書き込み自体を4月の末で一旦終えようと思いつつ、6月まで来るとは思っていませんでした。もう一度、原点に戻って充電しないといけないものがあるように思っています。

WindFaller · Answer

最初に、これはβ版で完成ではありませんが、こちらでは試してもらいながら、修正を加えたいと考えています。
実行ファイルは　ChangeFormatsTIOです。

最初に、
 #9のコードの
Set shTio = Worksheets("対応表1")
は複数の対応表になった時のものですから、
Set shTio = Worksheets("対応表")　←1 を取る
にしてください。

今回、二つの条件を、対応表を書き換えれば、以下のマクロで共有できます。
対応表の書き方は、#8の図を利用してください。

◎使用説明書
(転記マクロ・ベータ版）2017/ 5/30

まず、対応表を作成するマクロを実行してください。

転記する側(Sheet1), 転機される側(Sheet2)で、
転機される側(Sheet2)が全体のフォーマットの基盤になります。

転機される側のSheet2 の順番（4列目－D列）を元にして、
転記する側(Sheet1)の貼り付け場所を決めていきます。
伝票に当たるところは、「x」を入れます。

注意：対応表のタイトル行、伝票番号・桁番号などは、なるべく他に替えないでください。変える場合は、キーワードを残す必要があります。

伝票番号出力(5列目-E列）は、「x（任意）」を必ず一つ入れてください。Sheet2 の任意の場所に出力可能ですが、日付の場所には、入れないでください。
桁番号（6列目-F列）は、桁（伝票のアイテム番号）で、「k(任意）」を入れてください。

日付は選ばないことと、桁（アイテム番号）を出力するので、それ以外なら、選ぶことが可能です。

----------------------
'②
'MakeTaiohyoで、対応表をまず先に作成してください。

Sub MakeTaiohyo()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim shTio As Worksheet
Dim shName As String
Dim i As Long
Dim Ttl As String, Ttls As Variant
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
Ttl = "Sheet1,貼付位置,Sheet2,順番,伝番出力,桁番号"
Ttls = Split(Ttl, ",")
On Error GoTo ErrHandler
'シート追加
If MsgBox("シートを新たに作りますか？", vbOKCancel) = vbCancel Then Exit Sub
Worksheets.Add After:=Worksheets(Worksheets.Count)
　Set shTio = ActiveSheet
　 shName = "対応表"
shTio.Name = shName　'シート名の変更

With shTio
With .Range("A1").Resize(, UBound(Ttls) + 1)
　.Value = Ttls
　.Borders.LineStyle = xlContinuous
　.EntireRow.AutoFit
　.HorizontalAlignment = xlCenter
End With
sh1.Range("A1", sh1.Cells(1, Columns.Count).End(xlToLeft)).Copy
　.Range("A2").PasteSpecial xlPasteAll, , , True
　With .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
　　.Resize(, 2).Borders.LineStyle = xlContinuous
　End With
　
sh2.Range("A1", sh2.Cells(1, Columns.Count).End(xlToLeft)).Copy
　.Range("C2").PasteSpecial xlPasteAll, , , True
With .Range("C2", .Cells(Rows.Count, 3).End(xlUp))
　 On Error Resume Next
　.Find("日付").Interior.ColorIndex = 6
　On Error GoTo 0
　.Offset(, 1).FormulaLocal = "=ROW(R[-1]C)"
　.Value = .Value
　.Resize(, 4).Borders.LineStyle = xlContinuous
　.CurrentRegion.HorizontalAlignment = xlCenter
End With
End With
Exit Sub
ErrHandler:
If Err.Number <> 0 Then
　i = i + 1
　shName = "対応表"
　shName = shName & i
　If i > 10 Then Exit Sub '対応表は10個まで
　Resume
Else
　Exit Sub
End If
End Sub

WindFaller · Answer

おそくなってすみません。
もともと、設計図というか、フローチャートもなく頭の中で考えたもので、それで通用すると思ったら、ものの見事に失敗しました。フレキシブルに対応できるような、誰にでも可能なような「対応表」から転記できるように作り変えています。もう少しお時間ください。

その「対応表」とは、以下のようなものを考えています。
最初の質問のものでも、後の質問のものでも、入力の数字や文字を入れればできるようにします。

WindFaller · Answer

一応、報告だけ。何度もやり直していますが、すみません、次に続かないのです。
今のとろこ、追加に出された注文自体は、ほとんど理解していません。
しかし、ユーザーの任意の数字の記入で、転記が一対一の対応になるように、番号を代入する方式にすれば後はなんとかなると思い、全面的にやり直ししようとしましたが、逆に堂々巡りに入ってしまいました。

なお前回の桁番号に当たる部分はどこなのでしょうか？行番号でしょうか。

画像を見てください。

WindFaller · Answer

こんにちは。何か、私のいつものパターンと違うので、面食らっています。（^^; いつもは、9割以上のダメ出しだからです。久々、何年ぶりでしょうか？その理由は、私のコードは、かならず配列を使用するからです。 --- ・項目を増やす件なるべくコード自体をいじらないで、設定できないか工夫してみました。 ------ 一例として、出力項目に備考を加えました。項目設定の部分だけで、全てが設定が終わるはずですが、試してみていただけますか？設定項目を書き加えてみた例です。ほかはいじる必要がありません。(そのつもりです） '********設定項目******* 　'シート名　Set sh1 = Worksheets("Sheet1")　'元のデータ　Set sh2 = Worksheets("Sheet2")　'排出されるデータ　'出力の項目　　 Const OUT_titles As String = "日付,桁番号,品番,品名,個数,金額,備考"　'(1) 　　'項目はどの順番で入るか？　''日付(1),(伝票番号－>桁番号),品番(3),金額(4),個数(5),品名(6),備考(7) 　 out_Order = Array(1, 2, 3, 6, 5, 4, 7)　 '(2) 　'***************** '--------------------- '// 実際のコード Sub ChangeFormatsFlx() 'すでに伝票番号はソートが終わっているものとします。　Dim LastRow As Long 　Dim x As Long, y As Long 　Dim arr_in() 　Dim n As Long, i As Long, j As Long, k As Variant, m As Long 　Dim sh1 As Worksheet 　Dim sh2 As Worksheet 　Dim out_Order As Variant 　Dim b_num As Long 'ボーナス番号　　'********設定項目******* 　'シート名　Set sh1 = Worksheets("Sheet1")　'元のデータ '* 　Set sh2 = Worksheets("Sheet2")　'排出されるデータ '* 　'出力の項目　　 Const out_titles As String = "日付,桁番号,品番,品名,個数,金額" '* 　　''項目はどの順番で入るか？　''日付(1),(伝票番号>桁番号),品番(3),金額(4),個数(5),品名(6) 　 out_Order = Array(1, 2, 3, 6, 5, 4)　　'* 　'***************** 　'項目数のチェック　If UBound(Split(out_titles, ",")) <> UBound(out_Order) Then 　MsgBox "項目の順番のコマ数に過不足があります。", vbExclamation 　Exit Sub 　End If 　b_num = UBound(Split(out_titles, ",")) + 2 'ボーナス番号代入　'使用する変数の初期化　j = 1 　n = 1 　m = 0 　With sh1 　　LastRow = .Cells(Rows.Count, 1).End(xlUp).Row 　　ReDim arr_in(1 To LastRow + 1, 1 To b_num) 　　For i = 2 To LastRow 　　　For Each k In out_Order 　　　　If k = 2 Then 　　　　　m = m + 1 　　　　　arr_in(j, n) = m 　　　　Else 　　　　　arr_in(j, n) = .Cells(i, k).Value 　　　　End If 　　　　n = n + 1 　　　　If n > (b_num - 1) Then '1行の終わり　　　　　arr_in(j, b_num) = .Cells(i, 2).Value 　　　　　n = 1 　　　　　j = j + 1 　　　　　Exit For 　　　　End If 　　　Next 　　　'★伝票番号が変われば、mは、0にする　　　If Trim(.Cells(i + 1, 2).Value) <> Trim(.Cells(i, 2).Value) Then m = 0 　　Next 　End With 　'データの吐き出し　With sh2 　　x = 2　'開始行　　y = 1　'開始列　　.Activate 　　.UsedRange.ClearContents 　　'タイトル行　　With .Range("A1").Resize(, b_num - 1) 　　　.Value = Split(out_titles, ",") 　　　.HorizontalAlignment = xlCenter 　　End With 　　For i = 1 To UBound(arr_in) - 1 　　　For j = 1 To UBound(arr_in, 2) - 1 　　　　.Cells(x, y).Value = arr_in(i, j) 　　　　y = y + 1 　　　Next 　　　y = 1 　　　'挿入行　　　If arr_in(i + 1, b_num) <> arr_in(i, b_num) Then　'伝票番号出力　　　　x = x + 1 　　　　For j = 1 To UBound(arr_in, 2) - 1 　　　　　If j = 1 Then 　　　　　　.Cells(x, y).Value = arr_in(i, j) 　　　　　ElseIf j = 2 Then 　　　　　　.Cells(x, y).Value = arr_in(i, j) + 1 　　　　　ElseIf j = 4 Then 　　　　　　.Cells(x, y).Value = arr_in(i, b_num) 　　　　　ElseIf j > 4 Then 　　　　　　.Cells(x, y).Value = 0 '0　出力　　　　　End If 　　　　　y = y + 1 　　　　Next 　　　　y = 1 　　　End If 　　　x = x + 1 　　Next 　End With End Sub

WindFaller · Answer

>日付けの順番もバラバラなので「伝票番号」だけが区切りになりますそうでしたね。伝票番号で区切るのでした。ちょっと他に気がそがれることがいろいろあって、うっかりしてしまいました。こんな時には、マクロコードも何か変なところがあるかもしれません。業務で使われるマクロコードは、もう少しわかりやく書かなくてはならないはずですが、今は手抜きです。検討する余地ありです。 '// Sub ChangeFormats() 'すでに伝票番号はソートが終わっているものとします。　Dim LastRow As Long 　Dim x As Long, y As Long 　Dim arr_in() 　Dim n As Long, i As Long, j As Long, k As Variant, m As Long 　Dim sh1 As Worksheet 　Dim sh2 As Worksheet 　'****設定部分**********登録してください　Set sh1 = Worksheets("Sheet1")　'元のデータ　Set sh2 = Worksheets("Sheet2")　'排出されるデータ　'***************** 　'使用する変数の初期化　j = 1 　n = 1 　m = 0 　With sh1 　　LastRow = .Cells(Rows.Count, 1).End(xlUp).Row 　　ReDim arr_in(1 To LastRow + 1, 1 To 7) 　　For i = 2 To LastRow 　　　For Each k In Array(1, 2, 3, 6, 5, 4)　'項目の順序　　　　If k = 2 Then 　　　　　m = m + 1 　　　　　arr_in(j, n) = m 　　　　Else 　　　　　arr_in(j, n) = .Cells(i, k).Value 　　　　End If 　　　　n = n + 1 　　　　If k = 4 Then　'1行の終わり　　　　　arr_in(j, 7) = .Cells(i, 2).Value 　　　　　n = 1 　　　　　j = j + 1 　　　　　Exit For 　　　　End If 　　　Next 　　　'伝票番号が変われば、m＜カウント>は、0にする　　　If Trim(.Cells(i + 1, 2).Value) <> Trim(.Cells(i, 2).Value) Then m = 0 　　Next 　End With 　'データの吐き出し　With sh2 　　x = 2　'開始行　　y = 1　'開始列　　.Activate 　　.UsedRange.ClearContents 　　'タイトル行　　With .Range("A1:F1") 　　　.Value = Array("日付", "桁番号", "品番", "品名", "個数", "金額") 　　　.HorizontalAlignment = xlCenter 　　End With 　　For i = 1 To UBound(arr_in) - 1 　　　For j = 1 To UBound(arr_in, 2) - 1 　　　　.Cells(x, y).Value = arr_in(i, j) 　　　　y = y + 1 　　　Next 　　　y = 1 　　　'挿入行　　　If arr_in(i + 1, 7) <> arr_in(i, 7) Then 　　　　x = x + 1 　　　　For j = 1 To UBound(arr_in, 2) - 1 　　　　　If j = 1 Then 　　　　　　.Cells(x, y).Value = arr_in(i, j) 　　　　　ElseIf j = 2 Then 　　　　　　.Cells(x, y).Value = arr_in(i, j) + 1 　　　　　ElseIf j = 4 Then 　　　　　　.Cells(x, y).Value = arr_in(i, 7) 　　　　　ElseIf j > 4 Then 　　　　　　.Cells(x, y).Value = 0 　　　　　End If 　　　　　y = y + 1 　　　　Next 　　　　y = 1 　　　End If 　　　x = x + 1 　　Next 　End With End Sub

tatsu99 · Answer

以下の前提条件でマクロを作成して良いですか。
1）元のデータのシート名はSheet1
2）出力元のデータのシート名はSheet2
3) 一番左側の日付はＡ列である。（Sheet1,Sheet2共通）
4)Sheet1,Sheet2共に1行目は見出しである。
5)Sheet2は2行目から出力する。（マクロで見出しは作成しない）
6)同じ伝票は、連続した行に格納されている。
例　以下のようなケースはない
１０行　伝票番号=111-222　
１１行　伝票番号=111-888
１２行　伝票番号=111-222
質問の意図はSheet1の伝票番号が前行と変わった時、Sheet2へ前行の伝票番号を出力するが、
それで良いでしょうかという意味です。
もし、上記の例のようなケースがあると、111-222の番号が品名として2回出力されます。

WindFaller · Answer

私は、マクロで考えてみたのですが、分からない所があります。
それは、区分けは、品番の999で以って、切り分けるような気がしましたが、必ずしもそうではないようで、まさか、塗りつぶしの色ですか？
それとも、別に何かあるのですか？

エクセルデータをシステムインポートデータの形式に変更したい

① 注意：対応表がないと、このマクロは動きません。

こんにちは。

ご指摘の部分は、もともと、手元のコードでは「？」のついていたところで、どうするか反応を危ぶんでいた部分です。

最初に、これはβ版で完成ではありませんが、こちらでは試してもらいながら、修正を加えたいと考えています。

おそくなってすみません。

一応、報告だけ。

こんにちは。

>日付けの順番もバラバラなので「伝票番号」だけが区切りになります

以下の前提条件でマクロを作成して良いですか。

私は、マクロで考えてみたのですが、分からない所があります。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

①　注意：対応表がないと、このマクロは動きません。