With a single step

~千里の道も一歩からと信じたいノート~

作成物

【mod00_Operator】
Option Explicit

Sub Action()
'シート名定数クラスを作成する必要あり
Call mod01_MakeMaxDigitGenarateInfo.Action
Call mod02_GenerateMaxDigitData.Action
Call mod03_PasteTranspose.Action
End Sub

【mod01_MakeMaxDigitGenarateInfo】
Option Explicit

Sub Action()
Call generateSheet
Call copyTitleFormat
Call lookUp
End Sub

Sub generateSheet()

' シートを作成する
Dim sheet As Worksheet
Worksheets.Add After:=Worksheets("帳票CSV取込設定")
ActiveSheet.Name = "フル桁作成書式"
Set sheet = ActiveSheet ' 現在アクティブなシートを取得する
Worksheets.Add After:=Worksheets("フル桁作成書式")
ActiveSheet.Name = "フル桁データ"
sheet.Activate ' シートをアクティブにする

End Sub

Sub copyTitleFormat()

Dim sheetCopyFrom As Worksheet
Dim sheetCopyTo As Worksheet
Dim LastRow As Long

Set sheetCopyFrom = Worksheets("帳票CSV取込設定")
Set sheetCopyTo = Worksheets("フル桁作成書式")
LastRow = sheetCopyFrom.Cells(Rows.Count, 1).End(xlUp).Row

'項目名とシートの書式をコピーする
Worksheets("仕様書").Range("A1", "R2").copy Worksheets("フル桁作成書式").Range("A1", "R2")
Worksheets("仕様書").Range("A3", "R3").copy
Worksheets("フル桁作成書式").Range("A3", "R" & LastRow + 1).PasteSpecial (xlPasteFormats)

sheetCopyTo.Range("A3", "A" & LastRow + 1).Value = sheetCopyFrom.Range("A2", "A" & LastRow).Value
sheetCopyTo.Range("G3", "G" & LastRow + 1).Value = sheetCopyFrom.Range("B2", "B" & LastRow).Value
sheetCopyTo.Range("D3", "D" & LastRow + 1).Value = sheetCopyFrom.Range("C2", "C" & LastRow).Value
sheetCopyTo.Range("H3", "H" & LastRow + 1).Value = sheetCopyFrom.Range("E2", "E" & LastRow).Value
sheetCopyTo.Range("J3", "J" & LastRow + 1).Value = sheetCopyFrom.Range("F2", "F" & LastRow).Value
sheetCopyTo.Range("O3", "O" & LastRow + 1).Value = sheetCopyFrom.Range("G2", "G" & LastRow).Value

End Sub

Sub lookUp()

Dim sheetSearchFrom As Worksheet
Dim sheetSearchTo As Worksheet
Dim LastRowSearchFrom As Long
Dim LastRowSearchTo As Long
Dim i As Integer
Dim tbl As Range
Dim key As String

Set sheetSearchFrom = Worksheets("フル桁作成書式")
Set sheetSearchTo = Worksheets("仕様書")
LastRowSearchFrom = sheetSearchFrom.Cells(Rows.Count, 1).End(xlUp).Row
LastRowSearchTo = sheetSearchTo.Cells(Rows.Count, 1).End(xlUp).Row
Set tbl = sheetSearchTo.Range("G3", "R" & LastRowSearchTo)

'「フル桁作成書式」シートの最終行まで繰り返す
For i = 3 To sheetSearchFrom.Cells(Rows.Count, 1).End(xlUp).Row
key = sheetSearchFrom.Range("G" & i)
On Error Resume Next
'取込形式
sheetSearchFrom.Range("J" & i) = WorksheetFunction.VLookup(key, tbl, 4, False)
'表示形式
sheetSearchFrom.Range("L" & i) = WorksheetFunction.VLookup(key, tbl, 6, False)
'表示桁数
sheetSearchFrom.Range("O" & i) = WorksheetFunction.VLookup(key, tbl, 9, False)
'整数桁
sheetSearchFrom.Range("Q" & i) = WorksheetFunction.VLookup(key, tbl, 11, False)
'小数桁
sheetSearchFrom.Range("R" & i) = WorksheetFunction.VLookup(key, tbl, 12, False)
On Error GoTo 0
Next i

End Sub

【mod02_GenerateMaxDigitData】
Option Explicit

Sub Action()
Dim sheetDataGenerate As Worksheet
Dim i As Integer
Dim dataKind As String

Columns("S").NumberFormatLocal = "@"

Set sheetDataGenerate = Worksheets("フル桁作成書式")

For i = 3 To sheetDataGenerate.Cells(Rows.Count, 1).End(xlUp).Row
dataKind = sheetDataGenerate.Cells(i, 10)
Select Case dataKind
Case "テキスト"
Call DataGenerateString(i, sheetDataGenerate)
Case "数値"
Call DataGenerateNumeric(i, sheetDataGenerate)
Case "通貨"
Call DataGenerateCurrency(i, sheetDataGenerate)
Case "日付"
Call DataGenerateDate(i, sheetDataGenerate)
Case "郵便番号"
Call DataGeneratePostal(i, sheetDataGenerate)
Case "電話番号"
Call DataGenerateTelNo(i, sheetDataGenerate)
Case Else
GoTo continue
End Select
continue:
Next i
End Sub

Sub DataGenerateString(i As Integer, sheetDataGenerate As Worksheet)

Dim str As String
Dim outputDigit As String
str = "123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T123456789T"
outputDigit = sheetDataGenerate.Cells(i, 15)

sheetDataGenerate.Cells(i, 19) = Mid(str, 1, outputDigit)

End Sub

Sub DataGenerateNumeric(i As Integer, sheetDataGenerate As Worksheet)

Dim num As String
Dim inte As String
Dim deci As String
num = "12345678901234567890"
inte = sheetDataGenerate.Cells(i, 17)
deci = sheetDataGenerate.Cells(i, 18)

If Not deci = "" Then
num = Mid(num, 1, inte) & "." & Mid(num, 1, deci)
Else
num = Mid(num, 1, inte)
End If

Dim outputFormat As String
outputFormat = sheetDataGenerate.Cells(i, 15)

sheetDataGenerate.Cells(i, 19) = Format(num, outputFormat)

End Sub

Sub DataGenerateCurrency(i As Integer, sheetDataGenerate As Worksheet)

Dim money As String
Dim inte As String
Dim deci As String
money = "12345678901234567890"
inte = sheetDataGenerate.Cells(i, 17)
deci = sheetDataGenerate.Cells(i, 18)

If Not deci = "" Then
money = Mid(money, 1, inte) & "." & Mid(money, 1, deci)
Else
money = Mid(money, 1, inte)
End If

Dim outputFormat As String
outputFormat = sheetDataGenerate.Cells(i, 15)

If InStr(outputFormat, "\") Then
sheetDataGenerate.Cells(i, 19) = Format(money, "\" & outputFormat)
Else
sheetDataGenerate.Cells(i, 19) = Format(money, outputFormat)
End If

End Sub

Sub DataGenerateDate(i As Integer, sheetDataGenerate As Worksheet)
sheetDataGenerate.Cells(i, 19) = "1234年12月12日"
End Sub

Sub DataGeneratePostal(i As Integer, sheetDataGenerate As Worksheet)
sheetDataGenerate.Cells(i, 19) = "123-1234"
End Sub

Sub DataGenerateTelNo(i As Integer, sheetDataGenerate As Worksheet)
sheetDataGenerate.Cells(i, 19) = "123-123-1234"
End Sub

【mod03_PasteTranspose】
Option Explicit

Sub Action()
Dim sheetDataGenerate As Worksheet
Dim sheetDataCSV As Worksheet
Dim LastRow As Long

Set sheetDataGenerate = Worksheets("フル桁作成書式")
Set sheetDataCSV = Worksheets("フル桁データ")
LastRow = sheetDataGenerate.Cells(Rows.Count, 1).End(xlUp).Row

sheetDataGenerate.Range("S3", "S" & LastRow).copy
sheetDataCSV.Range("A1").PasteSpecial xlPasteAll, Transpose:=True
Application.CutCopyMode = False
End Sub