日々の雑感　〜これからのこと〜

https://flic.kr/p/2d3CfSU タイトル:高尾山、リフトで登る。2018年11月24日(土) 撮影日時：November 25, 2018 at 02:36AM 投稿日時：November 24, 2018 at 05:36PM

via IFTTT

Take a look https://ift.tt/2uayBQs via IFTTT

Take a look https://ift.tt/2uayBQs via IFTTT

https://flic.kr/p/2bawtcT タイトル:踏切 自由が丘近くで 10月31日(水) 撮影日時：November 01, 2018 at 02:25PM 投稿日時：November 01, 2018 at 05:25AM

via IFTTT

疲れたわ―――。

表題の通りです。 苦労した点はリストの選択と保存先の名前の設定です。 今回、はdim as String のところに　“Filename “をつくり それで、ActiveWorkbook.SaveAs Filenameとしました。 FALSE.xlsxで保存するということになってしまい、その部分で回らなかったので変更としました Sub dayday() Dim tod As Date Dim ya, mo, da, we As Long Dim i, LastRow As Long Dim FilNam, months, days, DirNam, Filename As String リスト.Select LastRow = Cells(Rows.Count, 1).End(xlUp).Row i = 2 Do While i <= LastRow Range("A1").Select tod = Cells(i, 1).Value ya = Year(tod) mo = Month(tod) da = Day(tod) we = Weekday(tod) 表.Select Range("J2").Value = ya & "年" Range("K2").Value = mo & "月" Range("L2").Value = da & "日" Range("N2").Value = we 'ActiveSheet.PrintOut   ActiveSheet.Copy If mo < 10 Then                   months = "0" & mo      Else         months = mo End If         If da < 10 Then   ...

主な目的はファイル移動及びファイル名変更、が目的です。 この後の展開としては、メールで送るというものと、送った後別途フォーム表示をしてその上で、また別のメールを送るというものを作成するためのファイル処理のコードです。 目新しさは無いですね。以前作成していますし。 とりあえずはここまで。 Sub filemoverename() Application.ScreenUpdating = False     Dim SavDir, FolderName, SavDir0 As String Dim hidut, dayd2 As String Dim days As Date Dim years, monthd, dayd, SheNem As Long     years = Year(Range("B2")) monthd = Month(Range("B2")) dayd = Day(Range("B2"))  If monthd < 10 Then                 month0 = years2 & "0" & monthd     Else        month0 = monthd End If  If dayd < 10 Then                 dayss1 = "0" & dayd     Else        dayss1 = dayd End If SheNem = years & month0 & dayss1 'dayd2 = years & "年" & month0 & "月" & dayss1 & "日" hidut = "今日は何の日_" & SheNem yearsmonth = yea...

さて、今日も休み朝から精米をしてきた いつものことだが、それなりにいい感じですね 空を動かすのは嫌いじゃないから」」さて今日も一日頑張りますs。

作業履歴ですねもう とりあえずここまではうまく動く Sub yy() Application.ScreenUpdating = False SC = ActiveWorkbook.Sheets.Count Ye = Year(Date) & "年" Mo = Month(Date) & "月" Da = Day(Date) & "日" i = 1 Do While i <= SC Worksheets(i).Copy Filename = Range("J5") & Ye & Mo & Da With ActiveWorkbook .SaveAs ThisWorkbook.Path & "\" & Filename & ".xlsx" .Close End With PrintCommunication = False With ActiveSheet.PageSetup .PrintArea = Range("A1:G29").Address .Zoom = 80 .PaperSize = xlPaperA4 .CenterHorizontally = True .CenterVertically = True .LeftMargin = Application.CentimetersToPoints(0.8) .RightMargin = Application.CentimetersToPoints(0.8) End With PrintCommunication = True ActiveWorkbook.Save i = i + 1 Loop Application.ScreenUpdating = True End Sub

大苦戦でした。 まぁあとはループの処理を当初の処理方法を変更 この後はシート名の変更、印刷フォームの指定をしていきます。 Sub ee() Application.ScreenUpdating = False SC = ActiveWorkbook.Sheets.Count Ye = Year(Date) & "年" Mo = Month(Date) & "月" Da = Day(Date) & "日" i = 1 Do While i <= SC Worksheets(i).Copy Filename = Range("J5") & Ye & Mo & Da With ActiveWorkbook .SaveAs ThisWorkbook.Path & "\" & Filename & ".xlsx" .Close End With i = i + 1 Loop Application.ScreenUpdating = True End Sub

Sub ee() For i = 1 To Sheets.Count Sheets(i).Name = "大好き" & i Next i ActiveWorkbook.Save Sub End

各シートを個別印刷（今回はシート連番でしたが、、、自分が求めているのは連番ではない。。。 ループを理解しないと先に進めそうにない。。。 Sub テスト的な何か() Dim i As Integer Dim N As Integer ' Dim Filename As String i = 1 Do While i <= Worksheets.Count Worksheets(i).Copy Filename = Range("J5") With ActiveWorkbook .SaveAs ThisWorkbook.Path & "\" & Filename & ".xlsx" N = N + 1 End With i = i + 1 Loop End Sub

とりあえずマクロのタイトル通り なお、エクセルのファイルで保存する際にダイヤログは表示されず、母体ファイルと同じフォルダに保存という設定にしています。（PDF変換時も出ません） 昔から目標としていたことが実現できました。そう、エクセルで特定セルの内容を保存する際、ダイヤログが表示されるということは当たり前と思っていたことが表示されないで処理されているということに一つ壁を乗り越えました。10年ぐらい前も一度挑戦をしたのですがその時はあきらめていました。 今回うまくできたのは色々なところで地震になった気がします。 これからもいろいろ勉強していきたいです。 ////////////////////////////////////////////////////////////////////////////////////////////////////////// Sub PDF作成､新しいブック作成後､値貼り付け書式のみ貼り付け後エクセル形式で保存､不要箇所削除上書き保存して閉じる() ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Range("BB13") & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False Cells.Select Selection.Copy Workbooks.Add Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _　 :=False, Transpose:=False Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Columns("AY:BV").Hidden = True ActiveWorkbook.SaveAs Filename:=Range("BB13...

シート全体選択し、新しいファイルにコピーをして名前を付けて保存（特定セルから)其の後不要部分削除し、上書き保存 BB13が保存時の名前、("AY:BV")は削除範囲 \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 成功エクセルマクロ() Cells.Select Selection.Copy Workbooks.Add' Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.Dialogs(xlDialogSaveAs).Show Arg1:=Range("BB13").Value Columns("AY:BV").Select Application.CutCopyMode = False Selection.Delete Shift:=xlToLe ActiveWorkbook.save End Sub \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 参考までに

シート名変更Ok Sub yy() Application.ScreenUpdating = False SC = ActiveWorkbook.Sheets.Count Ye = Year(Date) & "年" Mo = Month(Date) & "月" Da = Day(Date) & "日" i = 1 Do While i <= SC Worksheets(i).Copy Filename = Range("J5") & Ye & Mo & Da With ActiveWorkbook .SaveAs ThisWorkbook.Path & "\" & Filename & ".xlsx" .Close End With PrintCommunication = False With ActiveSheet.PageSetup .PrintArea = Range("A1:G29").Address .Zoom = 80 .PaperSize = xlPaperA4 .CenterHorizontally = True .CenterVertically = True .LeftMargin = Application.CentimetersToPoints(0.8) .RightMargin = Application.CentimetersToPoints(0.8) End With PrintCommunication = True ActiveSheet.Name = Range("J5") & Ye & Mo & Da ActiveWorkbook.Save i = i + 1 Loop Application.ScreenUpdating = True End Sub

Sub yy() Application.ScreenUpdating = False SC = ActiveWorkbook.Sheets.Count Ye = Year(Date) & "年" Mo = Month(Date) & "月" Da = Day(Date) & "日" i = 1 Do While i <= SC Worksheets(i).Copy PrintCommunication = False With ActiveSheet.PageSetup .PrintArea = Range("A1:G29").Address .Zoom = 80 .PaperSize = xlPaperA4 .CenterHorizontally = True .CenterVertically = True .LeftMargin = Application.CentimetersToPoints(0.8) .RightMargin = Application.CentimetersToPoints(0.8) End With PrintCommunication = True Filename = Range("J5") & Ye & Mo & Da ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & Filename & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Filename & ".xlsx" ActiveWorkbook.Close i = i + 1 Loop Applicati...

Sub yy() Application.ScreenUpdating = False SC = ActiveWorkbook.Sheets.Count Ye = Year(Date) & "年" Mo = Month(Date) & "月" Da = Day(Date) & "日" i = 1 Do While i <= SC Worksheets(i).Copy PrintCommunication = False With ActiveSheet.PageSetup .PrintArea = Range("A1:G29").Address .Zoom = 80 .PaperSize = xlPaperA4 .CenterHorizontally = True .CenterVertically = True .LeftMargin = Application.CentimetersToPoints(0.8) .RightMargin = Application.CentimetersToPoints(0.8) End With PrintCommunication = True ActiveSheet.Name = Range("J5") & Year(Date) & Month(Date) & Day(Date) Filename = Range("J5") & Ye & Mo & Da ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & Filename & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False ActiveWorkbook.SaveAs ThisWorkbook.Path & "...

ようやく、メール処理のところまでできたのですが、これからは一覧表化に挑戦をしていきたいと思います。 とりあえずは、添付ファイルの処理も確認できたので出来高70ということにしておきたいです。 実践を考えるとまだ出来高は４０弱ですがこの休み中にやろうと思っていたことはほぼ終わりました。 これからはゆっくりと夏休みを満喫したいと思います。 Sub yy() Dim Ye, Mo, Da, Filename, SN, toaddress, ccaddress, bccaddress As String Dim subject, mailBody, credit As String ' Dim outlookObj As Outlook.Application Dim mailItemObj As Outlook.mailItem Dim i, SC As Long Application.ScreenUpdating = False SC = ActiveWorkbook.Sheets.Count Ye = Year(Date) & "年" Mo = Month(Date) & "月" Da = Day(Date) & "日" i = 1 Do While i <= SC Worksheets(i).Copy PrintCommunication = False With ActiveSheet.PageSetup .PrintArea = Range("A1:G29").Address .Zoom = 80 .PaperSize = xlPaperA4 .CenterHorizontally = True .CenterVertically = True .LeftMargin = Application.CentimetersToPoints(0.8) .RightMargin = Application.CentimetersToPoints(0.8) End With PrintCommunication = True ActiveSheet.Name = Range("J5") & Year(Date) & Mo...

ちょっと解決まで時間がかかったけれど、現状実現したいことある程度できたのでよしとします。 それにしても転んで倒れて手が痛い。。。。 Sub 違うワークブック定型帳票データ複数行収集() Dim fso As FileSystemObject Dim MaxRow As Long Set fso = New FileSystemObject Dim pass As String pass = ThisWorkbook.Path & "\zzzz" Dim month As Date, department As String, fullname As String Dim i As Long, j As Long MaxRow = Cells(Rows.Count, 1).End(xlUp).Row j = MaxRow + 1 Dim f As File For Each f In fso.GetFolder(pass).Files With Workbooks.Open(f) With .Worksheets(1) i = 18 Do While .Cells(i, 1).Value <> "" Sheet1.Cells(j, 1).Value = .Cells(i, 1).Value Sheet1.Cells(j, 2).Value = .Cells(i, 2).Value Sheet1.Cells(j, 3).Value = .Cells(i, 3).Value Sheet1.Cells(j, 4).Value = .Cells(i, 4).Value Sheet1.Cells(j, 5).Value = .Cells(i, 5).Value Sheet1.Cells(j, 6).Value = .Cells(i, 6).Value i = i + 1 j = j + 1 Loop End With .Close End With Next f End Sub

試しに作成 どうなることやら Sub 新しいスライドを追加する() Dim i As Long i = 1 Do While i <= 5 With ActivePresentation.Slides .AddSlide _ Index:=.Count + 1, _ pCustomLayout:=.Item(.Count).CustomLayout End With i = i + 1 Loop End Sub

とにかく今日はうまく行けるところまで頑張ります Sub 新しいスライドを追加する() Dim i As Long i = 1 Do While i <= 5 With ActivePresentation.Slides .AddSlide _ Index:=.Count + 1, _ pCustomLayout:=.Item(.Count).CustomLayout End With i = i + 1 Loop ActivePresentation.SaveAs "C:\Users\PowerPoint\" & "大好きお願い" & Day(Date) & Hour(Time) & Minute(Time) & ".pptx", ppSaveAsDefault, msoCTrue ActivePresentation.Close End Sub

取り敢えず試してみた。 結果上手く動いたのでよしとしました。 今後の展開として 各スライドにエクセルの表に書いてある事項を入力していく 適切なスライドの数にしていく になります。 これからもトライアンドエラーの繰り返しですね。 Sub エクセルの行の分だけ新しいスライドを追加する() Dim i As Long Dim ECC As Long With New Excel.Application .Visible = True .Workbooks.Open "C:\ああ\aaaa.xlsx" End With Range("A1").Select Range(Selection, Selection.End(xlDown)).Select ECC = Selection.Rows.Count Excel.Application.Quit i = 1 Do While i <= ECC With ActivePresentation.Slides .AddSlide _ Index:=.Count + 1, _ pCustomLayout:=.Item(.Count).CustomLayout End With i = i + 1 Loop ActivePresentation.SaveAs "C:\あ\ & "大好きお願い" & Day(Date) & Hour(Time) & Minute(Time) & ".pptx", ppSaveAsDefault, msoCTrue ActivePresentation.Close End Sub

このぐらいのことしかやっていない。 Sub 収集() Dim fso As FileSystemObject Dim MaxRow As Long Set fso = New FileSystemObject Dim pass As String pass = ThisWorkbook.Path & "\テスト" Dim month As Date, department As String, fullname As String Dim i As Long, j As Long MaxRow = Cells(Rows.Count, 1).End(xlUp).Row j = MaxRow + 1 Dim f As File For Each f In fso.GetFolder(pass).Files     With Workbooks.Open(f)         With .Worksheets(1)             i = 18             Do While .Cells(i, 1).Value <> ""                 Sheet1.Cells(j, 1).Value = .Cells(i, 1).Value                 Sheet1.Cells(j, 2).Value = .Cells(i, 2).Value              ...

ちょっと手直しといった感じですね 基本形は変わっていません。 ただ簡易版といったところですね。 Dimのところに今回は入れていないものが入っているところからも分かるようにメール送信機能を削除しています。   Sub yy()     Dim Ye, Mo, Da, Filename, SN, toaddress, ccaddress, bccaddress As String     Dim subject, mailBody, credit As String '     Dim outlookObj As Outlook.Application     Dim mailItemObj As Outlook.mailItem     Dim i, SC As Long Application.ScreenUpdating = False SC = ActiveWorkbook.Sheets.Count i = 1 Do While i <= SC Worksheets(i).Copy Ye = Year(Range("E1")) & "年" Mo = Month(Range("E1")) & "月" Da = Day(Range("E1")) & "日" Filename = Range("B1") & Ye & Mo & Da ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Excelファイル\" & Filename & ".xlsx" PrintCommunication = False With ActiveSheet.PageSetup .PrintArea = Range("B2:Q52").Address .Zoom = 90 .PaperSize = xlPaperA4 .CenterHorizontally = True .CenterVertically = True .LeftMargin = Application.Ce...

単票からリスト化する作業ができそうです。 Offsetを使う予定ではなかったけれどこれが使いやすかったのでまぁ良しとしたいところです。贅沢は敵ですしね。。。 次の予定はもう決めてありますけれど、うまくできるかは定かではない。。。。   Sub yy()     Dim Ye, Mo, Da, Filename, SN, toaddress, ccaddress, bccaddress As String     Dim subject, mailBody, credit As String '     Dim outlookObj As Outlook.Application     Dim mailItemObj As Outlook.mailItem     Dim i, SC As Long Application.ScreenUpdating = False SC = ActiveWorkbook.Sheets.Count i = 1 Do While i <= SC 'Do While i <= 5 Worksheets(i).Copy Ye = Year(Range("E1")) & "年" Mo = Month(Range("E1")) & "月" Da = Day(Range("E1")) & "日" Filename = Range("B1") & Ye & Mo & Da ActiveWorkbook.SaveAs ThisWorkbook.Path & "\xxxx\" & Filename & ".xlsx" PrintCommunication = False With ActiveSheet.PageSetup .PrintArea = Range("B2:Q52").Address .Zoom = 90 .PaperSize = xlPaperA4 .CenterHorizontally = True .CenterVertically = ...

リストからさらにリスト作成ということで特にどう繰り返すかがなかなか思いつかなかった。 また、苦労した点は1列目の選択方法と必要な列の数えるところです。 思った通りにはなかなかならず、いろいろな方面から攻めてやっと結果が出たような気がします。これからの展開はカレンダー（Outlookで）の登録です。こちらはVBAを使うか否か、Outlookの機能そのままにしようか迷っています。 数が少ない場合りすとかする過程の中で取り込めて行ける方向で処理ができればと思います。 Googleカレンダーへの登録についてはすでに自分の中で方法が確立しできているのでここには載せないです。 Sub リストから別のリスト作成() Dim da1 As Date Dim sagyou1,  As String Dim i, j, RX, ConC As Long`この辺りはお好みになりそうです Dim FN As String Application.ScreenUpdating = False Range("A1").Select CR = Cells(Rows.Count, 1).End(xlUp).Row i = 2`1行目はタイトル行の為2行目からの処理ということで Do While i <= CR   ' Cells(i+1, 0).Value With Cells(Rows.Count, 1).End(xlUp)   End With da1 = ActiveSheet.Range("A" & CStr(i)).Value j = 1 ConC = WorksheetFunction.CountA(Range(Cells(i, 13), Cells(i, 18))) - 1`この行の処理はちょっと代替手段を考えたい                 Do While j <= ConC                 sagyo1 = Ac...

ＰＤＦ and ｅｘｃｅｌファイル　メール送信に作成ファイル削除 実用を考えれば送信履歴にファイルが残るので作成したファイルを削除したほうがいいのではないかということで作成したファイルは削除処理を最後に行っています。 残しておいてもいいけれどとりあえず。 Rangeの処理が大変でした。いろいろオブジェクトについて処理がもっと適切にできればいいと思いますが今回は大苦戦してしまったというのが正直なところです。 とりあえず勉強になりました。 個人ごとですが、昨晩脚をつってしまいかなりいたい感じで今います。 Sub mail and Outlook() Application.ScreenUpdating = False ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:="C:\xxxxxx\" + Range("AM2") & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False   ActiveSheet.Copy     Application.PrintCommunication = True     ActiveSheet.PageSetup.PrintArea = "$A$1:$AN$166"     Application.PrintCommunication = False     With ActiveSheet.PageSetup         .LeftHeader = ""         .CenterHeader = ""         .RightHeader = ""         .Left...

処理を考えてみました。 昨日の段階ではここまで。IFを使って文字処理やフォルダー作成を試みていますけれど、目的としてはいかに年月日を表示する際文字数を統一するか、つまり、月日が1桁のとき0をつけて統一させるかが今回の一番の課題でした。他のIF内は外のところのコピーですけれど、一つのIFのところにIFを入れての処理と考えてみてやってみたらうまく実行ができました。 とりあえずは不満はあるももののある程度のところはできたので良しとします。 うまい人ならもっと短いコードで書き上げるのでしょうが私はこれでしょりしていきたいです。 3種類あります Sub inunubuu(ByVal control As IRibbonControl) Application.ScreenUpdating = False years = Year(Range("H6")) months = Month(Range("H6")) dayss = Day(Range("H6")) fullday = years & months & dayss secell = Range("B3") SavDir0 = "C:\wewe\werwer\" hidut = secell years2 = Year(Range("BU6")) months2 = Month(Range("BU6")) dayss2 = Day(Range("BU6")) If months < 10 Then         yearmonth = years & "0" & months     Else        yearmonth = years & months End If If months2 < 10 Then         yearmonth2 = years2 & "0" & months2     Else        ye...

使われていないコードがあるけれどそれは無視してください。 基本的にはコピーアンドペーストしてある程度カスタマイズすればつかえるとおもいます。 前提条件として、Outlookでメールの送信するためのコードです。 現状としてはB列に各種値を入力するものとして、 To アドレスはB8 CCアドレスはB9 件名はB12 添付ファイルはB13。 本文はB15から各行です。 あとはオリジナルを自身で作り上げてください。 Sub masenddt() Application.ScreenUpdating = False Dim toaddress, ccaddress, bccaddress As String Dim subject, mailBody, credit As String ' Dim outlookObj As Outlook.Application Dim mailItemObj As Outlook.mailItem Dim MaxRow, MaxCol As Long Dim test1 As String Dim i As Long i = 15 test = ""      MaxRow = Cells.SpecialCells(xlCellTypeLastCell).Row                Do While i <= MaxRow 'If Range("B" & i) = "" Then 'test1 = test1 + vbCrLf 'Else 'test1 = test1 & Range("B" & i) + vbCrLf 'End If If i < MaxRow + 1 Then    If Range("B" & i) = "" Then     test1 = test1 + vbCrLf     Else      ...

ただ横着をして過ごすのはちょっよねと思うことはあるけれど、人を動かすには自分が動いたらダメということも分かっている。。。。「 静観してみます今日も