Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

18313 / 76732

←次へ　｜　前へ→


	【63862】Re:桁数に合わせてるやりかた

Hirofumi - 09/12/23(水) 13:39 -


	引用なし

	パスワード

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

2 hits

▼

【63859】桁数に合わせてるやりかた やす 09/12/23(水) 11:33