• ベストアンサー

EXCELの配列で

メールの本文を1行づつよみとってEXCELへ書き出そうと思っています。 Sub getMail1() Dim myOl As New Outlook.Application Dim dFolder As MAPIFolder Dim myItem As MailItem Dim delItem As MailItem Dim myRecipient As Recipient Dim i As Long, j As Long Const mAddress = 0, mTel = 1, mName = 2, mAge = 3 Set dFolder = myOl.GetNamespace _ ("MAPI").Folders("個人用フォルダ").Folders("単発") i = 1 On Error Resume Next For Each myItem In dFolder.Items i = i + 1 Set delItem = myItem.Reply For Each myRecipient In delItem.Recipients If InStr(1, myRecipient.Address, "@", vbBinaryCompare) _ <> 0 Then Exit For End If Next delItem.Delete With ActiveSheet myBody = Split(myItem.Body, vbCrLf) .Cells(i, 1).Value = myRecipient.Address .Cells(i, 2) = myItem.SenderName .Cells(i, 3) = myItem.Subject .Cells(i, 4) = myItem.ReceivedTime For j = 0 To UBound(myBody) i = i + 1 On Error Resume Next .Cells(i, 1) = myBody(j) .Cells(i, 1).MergeCells = True Next End With i = i + 1 Next Set myOl = Nothing End Sub このようなコードを書いて書き出すことは出来たのですが配列が縦になってしまいます。 横に配列したいのですが教えてください。 伊藤太郎 東京都 03-3123-4567を 伊藤太郎 東京都 03-3123-4567 としたいです。 よろしくお願いします。

質問者が選んだベストアンサー

  • ベストアンサー
回答No.2

For j = 0 To UBound(myBody) i = i + 1 On Error Resume Next .Cells(i, 1) = myBody(j) .Cells(i, 1).MergeCells = True Next を i=i+1 For j = 0 To UBound(myBody) On Error Resume Next .Cells(i, j+1) = myBody(j) .Cells(i, j+1).MergeCells = True Next にしたらどうでしょうか

aki08102001
質問者

お礼

ありがこうございます。 思い通りのものが出来ました。 感謝です!!

その他の回答 (1)

回答No.1

ここまで出来ているのなら、答えなくてももしかしたらもうわかってしまっているかもしれませんが 「 .Cells(i, 1).Value = myRecipient.Address .Cells(i, 2) = myItem.SenderName .Cells(i, 3) = myItem.Subject .Cells(i, 4) = myItem.ReceivedTime 」 この部分の Cells(RowIndex,ColumnIndex) RowIndexはExcelの行を指定します ColumnIndexはExcelの列を指定します となるので 「 .Cells(1, i).Value = myRecipient.Address .Cells(2, i) = myItem.SenderName .Cells(3, i) = myItem.Subject .Cells(4, i) = myItem.ReceivedTime 」 このようにすれば横に書き出すことが出来ると思います

aki08102001
質問者

補足

その通りにしたら1行しか書き込まれませんでした。

関連するQ&A

  • ダイレクトに目的のフォルダを指定する方法は?

    全てのフォルダをループするのではなく、 ダイレクトに目的のフォルダを指定する方法はありますか? アクセスからアウトルックの該当のフォルダの中身を取得したいのですが 下記コードで目的通り取得できるのですが コードが遠回りの気がします。 ダイレクトにフォルダを指定する方法があれば教えてください。 Sub test() Dim myNaSp As Namespace Dim myFolder As MAPIFolder Dim mySecFolder As MAPIFolder Dim myThrFolder As MAPIFolder Dim FolderName As String Dim myItem As MailItem Dim myindex As Long Set cn = CurrentProject.Connection Set myNaSp = GetNamespace("MAPI") For Each myFolder In myNaSp.GetDefaultFolder(olFolderInbox).Folders For myindex = 1 To myFolder.Items.Count Set myItem = myFolder.Items(myindex) If myFolder.Name = "testフォルダ" Then Debug.Print myItem.Body End If Next Next Set myNaSp = Nothing Set myFolder = Nothing End Sub

  • ExcelのVBAの配列に関する質問です。

    ExcelのVBAの配列に関する質問です。 sheet1のデータをsheet2に表示するVBAを作成しています。。 sheet1のデータは7行目からスタートし、sheet2のデータは26行目からスタートしています。。 sheet1とsheet2の列は同じ並びではないため、それぞれのシートの列番号をCellsを用いて指定しています。 Sub test1() Dim endrow As Long endrow = Worksheets("sheet1").Range("A65536").End(xlUp).Row Dim i As Long Dim j As Long For i = 7 To endrow j = i + 19 Worksheets("sheet2").Cells(j, 1) = Worksheets("sheet1").Cells(i, 2) Worksheets("sheet2").Cells(j, 8) = Worksheets("sheet1").Cells(i, 28) Worksheets("sheet2").Cells(j, 9) = Worksheets("sheet1").Cells(i, 31) Worksheets("sheet2").Cells(j, 10) = Worksheets("sheet1").Cells(i, 32) ・ ・ ・ ※長いので省略 Next i End Sub 上記のtest1は正常に動くのですが、データ量が多いため、処理に時間がかかってしまいます。 高速化できないかと、以下のように変更しました。 Sub test2() Dim dataRange1 As Variant Dim dataRange2 As Variant dataRange1 = Worksheets("sheet1").Range("A1:GI10006") dataRange2 = Worksheets("sheet2").Range("A1:DZ10018") Dim endrow As Long endrow = Worksheets("sheet1").Range("A65536").End(xlUp).Row Dim i As Long Dim j As Long For i = 7 To endrow j = i + 19 dataRange2(j, 1) = dataRange1(i, 2) dataRange2(j, 8) = dataRange1(i, 28) dataRange2(j, 9) = dataRange1(i, 31) dataRange2(j, 10) = dataRange1(i, 32) ・ ・ ・ ※長いので省略 Next i End Sub test2は、エラーメッセージ等は表示されませんが、sheet2にデータが表示されません。 ちなみに、以下のようにsheet1のみ配列化した場合は、正常に表示されました。 Worksheets("sheet2").Cells(j, 1) = dataRange1(i, 2) Worksheets("sheet2").Cells(j, 8) = dataRange1(i, 28) Worksheets("sheet2").Cells(j, 9) = dataRange1(i, 31) Worksheets("sheet2").Cells(j, 10) = dataRange1(i, 32) test2は、どこが間違っているのでしょうか? ご教示ください。 よろしくお願いいたします。

  • EXCEL VBA2010 MsgBox

    Sub 重複() Dim i As Long, j As Long For i = 6 To 500 For j = 3 To 3 If WorksheetFunction.CountIf(Range("C6:C500"), Cells(i, j)) > 1 Then Cells(i, j).Interior.ColorIndex = 6 End If Next j Next i End Sub このVBAに重複が何件ありますよというメッセージを出したいです。 MsgBoxの入れ方を教えてください。

  • エクセルVBAの配列について

    エクセルVBAの配列について VBAをはじめたばかりの初心者です。 現在、下記のようにデータを配列の中に入れ、 別シートに書き出そうとしております。 (配列へ読み込むところのみ) Dim 配列(1 To 件数, 1 To 9) As Variant For j =1 To 件数 For i = 2 To L If Cells(i, 2).Value = Tx_month Then For k = 3 To 11 配列(j, k - 2) = Cells(i, k).Value Next k End If Next j,i 現状では、データの最終行のみを「件数」分書き出してしまいます。 jとiのForが重なっているからだと思うのですが、どう書き直したら良いか分かりません。 質問をさせていただくのも初めてなので、分かりづらく恐縮ですが お力添え頂けますと幸いです。 どうぞ宜しくお願い致します。

  • EXCEL VBAの配列でわかりません。

    こんなコードがあるのですが、最後の他のシート(作業中シート)に書き込もうとするとエラーになってしまいます。”Sheets("作業中").”を抜くと同じシートに結果は返ってくるのですが…。コードの内容は、ある範囲のある列から空白ではないセルを探し出してその行のデータを配列で汲み取り、他のシートに一括で洗い出すというものです。 Sub 作業中() Dim myRow As Long Dim Data As Variant Dim WC() As Variant Dim WCE() As Variant myRow = Range("H1").CurrentRegion.Rows.Count Data = Range("H1:M" & myRow).Value For i = 1 To myRow If Data(i, 5) <> "" Then a = a + 1 Else b = b + 1 End If Next ReDim WC(a) ReDim WCE(b) c = 0 d = 0 For i = 1 To myRow If Data(i, 5) <> "" Then WC(c) = Range("H" & i & ":K" & i).Value c = c + 1 Else WCE(d) = Range(Cells(i, 8), Cells(i, 11)).Value d = d + 1 End If Next For i = 0 To a Range(Cells(i + 1, 15), Cells(i + 1, 18)).Value = WC(i) Next For i = 0 To b Range(Cells(i + 1, 19), Cells(i + 1, 22)).Value = WCE(i) Next e = Range(Cells(1, 15), Cells(a, 18)).Value Sheets("作業中").Range(Cells(1, 1), Cells(a, 4)).Value = e End Sub ちなみに同じシートから↓のコードを実行するとうまくいきます。 なぜ~??わからな~い??おしえてくださーい!! Sub test() Dim a As Variant a = Range("H1:K4") Sheets("作業中").Range("N1:Q4") = a End Sub

  • 配列のフリーズを解消してください。

    Sub データ原本() Dim wsAll As Worksheet Set wsAll = Worksheets("All(5)") Dim lRow As Long, lCol As Long Dim i As Long, j As Long, cnt As Long With Worksheets("データ原本") '日付S行を日付に変更(「.」を「/」に置換) lRow = .Cells(Rows.Count, 1).End(xlUp).Row Dim MyArray As Variant MyArray = Range(.Cells(10, 1), .Cells(lRow, 1)) For i = 1 To lRow - 9 MyArray(i, 1) = Replace(MyArray(i, 1), ".", "/") Next Range(.Cells(10, 1), .Cells(lRow, 1)) = MyArray Erase MyArray '配列の初期化 '「天気」両サイドの &「内・外」両サイドの空白スペースを削除 lRow = .Cells(Rows.Count, 1).End(xlUp).Row MyArray = Range(.Cells(10, TNK), .Cells(lRow, TNK)) For i = 1 To lRow - 9 MyArray(i, 1) = Trim(MyArray(i, 1)) Next Range(.Cells(10, TNK), .Cells(lRow, TNK)) = MyArray Erase MyArray '配列の初期化 '数値0のデータ行の行削除 lRow = .Cells(Rows.Count, 1).End(xlUp).Row lCol = .Cells(9, Columns.Count).End(xlToLeft).Column Dim arr_A As Variant, arr_B As Variant arr_A = Range(.Cells(9, 1), .Cells(lRow, lCol)).Value ReDim arr_B(1 To lRow - 8, 1 To lCol) cnt = 0 For i = 1 To lRow - 8 If arr_A(i, 18) <> 0 Then cnt = cnt + 1 For j = 1 To lCol arr_B(cnt, j) = arr_A(i, j) Next j End If Next i .Range("A9").Resize(lRow, lCol).Value = arr_B End With End Sub  上記のコードを2回実行すると2回目には、 MyArray(i, 1) = Replace(MyArray(i, 1), ".", "/")のところで「型が一致しません。」とフリーズします。かと言って 「 '数値0のデータ行の行削除」コードを一括削除して、実行ボタンを何度押してもフリーズすることはありません。どこに不具合が生じているのかわからないのですが、どなたか名回答を宜しくお願いします。

  • VBA 複数のシートをまたいでの連想配列

    win7、Excelは2013を使用しています。 添付画像の様に、12シートの合計を連想配列に格納しsheet13に書き出したいのですが、プロシージャーの下から6行目のところで、エラーコード451が出ます。 どの様に変更すれば良いか教えて下さい。 Sub 年間集計() Dim Dic Dim i As Integer Dim j As Integer Dim sh As Worksheet Dim rng As Range Dim buf As String Dim num As Integer Set Dic = CreateObject("Scripting.Dictionary") For Each sh In Worksheets For Each rng In sh.Range("J2", sh.Cells(Rows.Count, 10).End(xlUp)) buf = rng.Value num = rng.Offset(, 1).Value If Not Dic.Exists(buf) Then Dic.Add buf, num Else Dic.Item(buf) = Dic.Item(buf) + num End If Next rng Next sh j = 2 With Worksheets("Sheet13") For i = 0 To Dic.Count - 1 .Cells(j, 1) = Dic.Keys(i)   ’エラー箇所 .Cells(j, 2) = Dic.Items(i) j = j + 1 Next i End With End Sub

  • Outlookで選択したメールのみ書き出すVBA

    こんにちは。 Outlookで選択したメールのみ書き出すVBAを教えてください。 下記のコードまでは作成ができ、書き出すことには成功しました。 ですが、下記コードだとフォルダ内すべてのメールが書き出しされてしまいます。 選択しているメールのみ書き出すコードに書き換えたいのですが、 どこを変えたらよいかわかりません。 どなたかご教示いただけると幸いです。 ------------------------------------------- Sub メール書き出し() On Error Resume Next Set myMFolder = Application.ActiveExplorer.CurrentFolder Set xlApp = CreateObject("Excel.Application") Set myBook = xlApp.Workbooks.Add xlApp.Visible = True With myBook.Worksheets(1) i = 1 For Each myItem In myMFolder.Items '受信日時 .Cells(i, 1) = myItem.ReceivedTime '受信者名 .Cells(i, 2) = myItem.Recipients(1).Name '件名 .Cells(i, 3) = myItem.Subject '送信者名 .Cells(i, 4) = myItem.SenderName '受信者名 .Cells(i, 5) = myItem.Recipients(1).Addresss i = i + 1 Next myItem End With Set xlApp = Nothing End Sub

  • 一定の規則でエクセルに並んでいる表を、別シートに元のSheetに設定されているNO順で貼り付ける

    少しややこしいマクロなのですが、 Sheet1に表が左から順に飛び飛びで並んでいます。 1番目の表の1行目の項目値がNO.1で、2番目の表の1番目がNO.2、3番目の表の1番目がNO.3で。。。。と続いていき、最後の表の1行目までいくと、一番始めの表の2行目に続きます。 それを別シートにNO順に1つの表として完成させるマクロをVBAで作りたいと思っています。 調べ回って途中まではやってみたのですが、一向に進まないので教えて下さい(*_ _) 以下はエラーになったマクロです。 Sub CopyCell() Dim CopySource, PasteDist As Range Dim i As Integer Dim j As Integer Dim k As Integer For i = 1 To 7 For j = 1 To 7 For k = 2 To 33 Step 8 Set CopySource = Sheets(1).Range(Cells(i, k), Cells(i, k + 6)) Set PasteDist = Sheets(2).Range(Cells(j, 1), Cells(j, 7)) PasteDist = CopySource Next k Next j Next i End Sub

  • Excel VBAライフゲーム

    ExcelのVBAでライフゲームを作りたいのですが、次のプログラムの途中以降がわかりません。 もしよろしければ、このつづきの簡単な実行できるVBAライフゲームを教えてください。 続きのプログラムを教えていただけたら幸いです。 Option Explicit Const ALIVE As Integer = 1 Const DEAD As Integer = 0 Const SIZE As Integer = 19 Const Tmax As Integer = 100 Dim C(SIZE, SIZE) As Integer Sub LifeGame() Dim InitRate As Single Dim T As Integer Dim N As Integer Dim Cnext(SIZE, SIZE) As Integer Dim I As Integer, J As Integer InitRate = -1 Do While InitRate < 0 Or 1 < InitRate Loop For I = 0 To SIZE For J = 0 To SIZE If Rnd() < InitRate Then C(I, J) = ALIVE Else C(I, J) = DEAD End If Next J Next I For T = 1 To Tmax For I = 0 To SIZE For J = 0 To SIZE If C(I, J) = ALIVE Then Cells(I + 1, J + 1).Value = "■" Else Cells(I + 1, J + 1).Vallue = "" End If Next J Next I For I = 0 To SIZE For J = 0 To SIZE N = Count(I, J) Next J Next I For I = 0 To SIZE For J = 0 To SIZE C(I, J) = Cnext(I, J) Next J Next I Next T End Sub Function Count(I As Integer, J As Integer) As Integer End Function