daily pastebin goal
40%
SHARE
TWEET

Untitled

a guest Jan 24th, 2019 72 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Sub mergeCSV()
  2.  
  3.     Dim csvDir As String
  4.     'ディレクトリの指定
  5.     With Application.FileDialog(msoFileDialogFolderPicker)
  6.         If .Show = True Then
  7.             csvDir = .SelectedItems(1)
  8.         Else: End
  9.         End If
  10.     End With
  11.    
  12.     '出力用ワークブックを作成
  13.     Dim wb As Workbook
  14.     Set wb = Workbooks.Add
  15.  
  16.     'ディレクトリ内のファイルを順に開き内容を新しいブックにコピーする
  17.     Dim fileName As String
  18.     fileName = Dir(csvDir & Application.PathSeparator & "*.csv")
  19.     Do While fileName <> ""
  20.         'csvファイルの内容をブックにコピー
  21.         Call copyCsvToBook(csvDir & Application.PathSeparator & fileName, wb)
  22.         fileName = Dir()
  23.     Loop
  24.  
  25. End Sub
  26.  
  27. 'csvファイルの内容をブックにコピー
  28. Function copyCsvToBook(csvPath As String, wb As Workbook)
  29.  
  30.     Dim r_num As Long, c_num As Long
  31.     Dim strLine As String
  32.     Dim arrLine() As String 'カンマでsplitして格納
  33.     Dim n As Integer
  34.    
  35.     r_num = wb.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
  36.    
  37.     '文字化け対策として文字コードをutf-8にするためADODB.Streamオブジェクトを生成
  38.     Dim adoSt As Object
  39.     Set adoSt = CreateObject("ADODB.Stream")
  40.  
  41.     With adoSt
  42.         .Charset = "UTF-8"
  43.         .Open
  44.         .LoadFromFile (csvPath)
  45.        
  46.         Do Until .EOS           'Streamの末尾まで繰り返す
  47.             strLine = .ReadText(adReadLine) 'Streamから1行取り込み
  48.             strLine = replaceDelimiter(strLine, ",", "|") 'データ中にカンマが存在するため区切り文字を"|"に置換
  49.             arrLine = Split(Replace(strLine, """", ""), "|") 'strLineを|で区切りarrLineに格納
  50.  
  51.             For c_num = 0 To UBound(arrLine)
  52.                 wb.Worksheets(1).Cells(r_num, c_num + 1).Value = arrLine(c_num)
  53.             Next c_num
  54.             r_num = r_num + 1
  55.  
  56.         Loop
  57.  
  58.         .Close
  59.     End With
  60. End Function
  61.  
  62. '区切り文字を置換する
  63. Function replaceDelimiter(ByVal strLine As String, ByVal replacedDel As String, ByVal newDel As String) As String
  64.  
  65.     Dim strTemp As String
  66.     Dim quotCount As Long
  67.    
  68.     Dim pos As Long
  69.     For pos = 1 To Len(strLine)
  70.         '1文字ずつ切り出し判定する
  71.         strTemp = Mid(strLine, pos, 1)
  72.  
  73.         'strTempがダブルクォーテーションなら
  74.         'ダブルクォーテーションのカウントを1増やす
  75.         If strTemp = """" Then
  76.             quotCount = quotCount + 1
  77.  
  78.         'strTempが対象の区切り文字、且つダブルクォーテーションのカウントが2の倍数なら
  79.         '新たな区切り文字に置き換える
  80.         ElseIf strTemp = replacedDel Then
  81.             If quotCount Mod 2 = 0 Then  
  82.                 strLine = Left(strLine, pos - 1) & newDel & Right(strLine, Len(strLine) - pos)
  83.             End If
  84.         End If
  85.    
  86.     Next pos
  87.    
  88.     replaceDelimiter = strLine
  89.  
  90. End Function
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top