| |
A列先頭行は列見出しとします
Option Explicit
Public Sub Sample()
Dim i As Long
Dim lngRows As Long
Dim rngList As Range
Dim vntData As Variant
Dim vntFilename As Variant
Dim dfn As Integer
Dim strFilter As String
Dim strBuff As String
Dim strProm As String
'フィルタ文字列を作成
strFilter = "Text File (*.txt),*.txt"
'出力ファイル名を取得
vntFilename = Application.GetSaveAsFilename(, strFilter)
If VarType(vntFilename) = vbBoolean Then
strProm = "マクロがキャンセルされました"
GoTo Wayout
End If
'◆Listの先頭セル位置を基準とする（先頭列の列見出しのセル位置）
Set rngList = ActiveSheet.Range("A1")
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
If lngRows <= 0 Then
strProm = "データが有りません"
GoTo Wayout
End If
'列データを配列に取得
vntData = .Offset(1).Resize(lngRows + 1).Value
End With
'出力ファイルをOpen
dfn = FreeFile
Open vntFilename For Output As dfn
'Key列に就いて繰り返し
For i = 1 To lngRows
strBuff = Right(String(4, "0") & vntData(i, 1), 4)
Print #dfn, "項番" & i & AdjustData(strBuff, 6, "R")
Next i
Close #dfn
strProm = "処理が完了しました"
Wayout:
Set rngList = Nothing
MsgBox strProm, vbInformation
End Sub
Private Function AdjustData(ByVal strData As String, _
ByVal lngLength As Long, _
Optional ByVal strAlign As String = "L") As String
' Dataをフィールド長に調整
' lngLengthはフィールドの長さを半角何文字分（バイト単位）で
' strDataはデータを文字列の型で
' strAlignは、右詰なら"R"、"r"で、 左詰なら"L"、"l"で（ディフォルトは"L"）
Dim strSpace As String
Dim strTmp As String
Dim i As Long
Dim lngCount As Long
If strData = "" Then
AdjustData = Space(lngLength)
Exit Function
End If
If Len(strData) > lngLength Then
strData = Left(strData, lngLength)
End If
'文字列を Unicode からシステムの既定のコード ページに変換します
strTmp = StrConv(strData, vbFromUnicode)
'フィールド長よりDataが長い場合、２バイト文字の処理を行います
i = 1
Do Until LenB(strTmp) <= lngLength
strTmp = StrConv(Left(strData, Len(strData) - i), vbFromUnicode)
i = i + 1
Loop
'Spaceで調整する必要がある場合
If lngLength > LenB(strTmp) Then
'長さ調整用のスペースを作成します
strSpace = StrConv(String$(lngLength, " "), vbFromUnicode)
'中央揃えの場合
If strAlign = "C" Or strAlign = "c" Then
'Spaceを文字列で置き換えます
MidB(strSpace, ((lngLength - LenB(strTmp)) \ 2) + 1) = strTmp
Else
'Dataをフィールド長に調整します
If strAlign = "R" Or strAlign = "r" Then
'Spaceを文字列で置き換えます
MidB(strSpace, lngLength - LenB(strTmp) + 1) = strTmp
Else
'Spaceを文字列で置き換えます
MidB(strSpace, 1) = strTmp
End If
End If
'システムの既定のコード ページを使って文字列を Unicode に変換します
AdjustData = StrConv(strSpace, vbUnicode)
Else
'システムの既定のコード ページを使って文字列を Unicode に変換します
AdjustData = StrConv(strTmp, vbUnicode)
End If
End Function
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
