| 
    
     |  | Option Explicit 
 Public Sub Sample1()
 
 '◆データベースのデータ列数(A列)
 Const clngColumns As Long = 1
 
 Dim i As Long
 Dim lngRows As Long
 Dim rngList As Range
 Dim rngResult As Range
 Dim vntData As Variant
 Dim strResult() As String
 Dim strProm As String
 
 '◆Listの先頭セル位置を基準とする(A列の列見出しのセル位置)
 Set rngList = ActiveSheet.Cells(1, "A")
 
 '◆出力先の先頭セル位置を基準とする(C列の列見出しのセル位置)
 Set rngResult = rngList.Parent.Cells(1, "C")
 
 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
 
 '画面更新を停止
 Application.ScreenUpdating = False
 
 With rngResult
 For i = 1 To lngRows
 strResult = Split(vntData(i, 1), "-", , vbBinaryCompare)
 .Offset(i).Resize(, UBound(strResult) + 1).Value = strResult
 Next i
 End With
 
 strProm = "処理が完了しました"
 
 Wayout:
 
 '画面更新を再開
 Application.ScreenUpdating = True
 
 Set rngList = Nothing
 Set rngResult = Nothing
 
 MsgBox strProm, vbInformation
 
 End Sub
 
 Public Sub Sample2()
 
 '◆データベースのデータ列数(A列〜C列)
 Const clngColumns As Long = 3
 
 Dim i As Long
 Dim lngRows As Long
 Dim rngList As Range
 Dim rngResult As Range
 Dim vntData As Variant
 Dim strResult As String
 Dim strProm As String
 
 '◆Listの先頭セル位置を基準とする(A列の列見出しのセル位置)
 Set rngList = ActiveSheet.Cells(1, "A")
 
 '◆出力先の先頭セル位置を基準とする(C列の列見出しのセル位置)
 Set rngResult = rngList.Parent.Cells(1, "E")
 
 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, 3).Value
 End With
 
 '画面更新を停止
 Application.ScreenUpdating = False
 
 With rngResult
 For i = 1 To lngRows
 '      strResult = vntData(i, 1) & "-" & vntData(i, 2) & "-" & vntData(i, 3)
 strResult = Format(vntData(i, 1), "00") _
 & "-" & Format(vntData(i, 2), "00") _
 & "-" & Format(vntData(i, 3), "00")
 .Offset(i).Value = strResult
 Next i
 End With
 
 strProm = "処理が完了しました"
 
 Wayout:
 
 '画面更新を再開
 Application.ScreenUpdating = True
 
 Set rngList = Nothing
 Set rngResult = Nothing
 
 MsgBox strProm, vbInformation
 
 End Sub
 
 |  |