FC2ブログ
エホバの証人二世の、個人研究&趣味blogです。
2018/08«│ 2018/09| 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 »2018/10
文字色の変化のON/OFFが出来ます。文字サイズ文字サイズ:大文字サイズ:中文字サイズ:小
07:25:21
最近メンバーさんたちで話すのが、そういう話なんですね。
私自身26歳で「そろそろ決めてね」と言われているのですが……。
自分の進退をなかなか決められず、しかも他の人の状況を見なければならないとなる
と結構大変です。ストレスが溜まる、と言えばいいのでしょうか。

私自身は今現在では全く満足できないので、これ以上を!!!となっていますが。
8月は80時間いかなかったんですよね…作業時間。普段は100時間か行ってさら
に作業してってなっているのですが……。
9月は予定表上がってて、100時間越えかな~ってところです。

<平成30年9月予定表>

1.HyperLink→コピーマクロの作成
2.100時間以上作業
3.名前の定義フォーム
4.名前の定義からコピーするHyperLink
5.リンクの解除・隠れたオブジェクト・コメントを削除する
6.不要な名前の定義の削除
7.一括一行作成
8.不要なシートだけ消す
9.PDFのハイパーリンクを作成
10.ハイパーリンクで印刷設定する。(A3横・A4縦・A4横
11.データの削除
12.ブック一覧(更新用)
13.名前の定義の範囲をコピーするマクロ
14.期間の有無を抽出するリスト
15.一覧表もっと楽マクロ
16.選択範囲を移動する
17.ファイル一覧(ActiveSheet/A1にフォルダアドレス/空白の場合指定/フォルダ名=シート名)
18.シート名でPDFを作成する
19.書式なしコピー(フィル)をマクロで行う



23:48:31
PDF作成アドイン

今回まとめを使って作ってみました。
まとめって気楽に作れて良いですね
Amazonのレビューも始めました♥

レビュー



22:47:26
Sub 印刷範囲()
x = 1
Do Until ThisWorkbook.Worksheets("印刷設定").Cells(x, 1) = ActiveSheet.Name
If ThisWorkbook.Worksheets("印刷設定").Cells(x, 1) = "" Then
Exit Do
End If
x = x + 1
Loop
If ActiveSheet.PageSetup.PrintArea = vbNullString Then
Else
ThisWorkbook.Worksheets("印刷設定").Cells(x, 1) = ActiveSheet.Name
ThisWorkbook.Worksheets("印刷設定").Cells(x, 3) = ActiveSheet.PageSetup.PrintArea
ThisWorkbook.Worksheets("印刷設定").Cells(x, 2) = ActiveSheet.PageSetup.PaperSize
ThisWorkbook.Worksheets("印刷設定").Cells(x, 4) = ActiveSheet.PageSetup.Orientation
End If
End Sub

Sub 印刷範囲設定()
x = 1
Do Until InStr(ThisWorkbook.Worksheets("印刷設定").Cells(x, 1), ActiveSheet.Name) <> 0
If ThisWorkbook.Worksheets("印刷設定").Cells(x, 1) = "" Then
Exit Do
End If
x = x + 1
Loop
With ActiveSheet.PageSetup
.PrintArea = Worksheets("印刷設定").Cells(x, 3)
.PaperSize = Worksheets("印刷設定").Cells(x, 2)
.Orientation = Worksheets("印刷設定").Cells(x, 4)
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
End Sub

印刷範囲をThisworkbookに保存します。
使用するシートにマクロを入れます。



23:52:16
Sub 書式なしフィルをマクロで行う()
Dim a As Variant
Set a = Application.InputBox("コピーセルを選択して下さい", Type:=8)
Dim b As Variant
Set b = Application.InputBox("貼り付けるセルを選択して下さい", Type:=8)
Range(a.Address).Select
Selection.AutoFill Destination:=ActiveSheet.Range(Selection, b.Address), Type:=xlFillValues
End Sub

マクロですっと出てくるとすごく使いやすくて楽しいです。
これからもっと色々なマクロを作っていきたいと思います。
なんか、上手く行かないことも多いので……。マクロって難しい。

これからは一つ一つのファイルにマクロを追加して使いやすくしたい。





2018/09/19
23:34:32
着せ替えバトルゲームなんですけど、めっちゃ面白くて最近よくプレイしています。
変な組み合わせでもSS取れたりするのが謎ですが。
あと、バトルだ勝たないといけないので、センスない服装がふえていく;;;

19:33:33
Application.CommandBars("Worksheet Menu Bar").Controls("印刷設定").Delete
Application.CommandBars("Worksheet Menu Bar").Controls("ブックリンクリストの作成").Delete
Application.CommandBars("Worksheet Menu Bar").Controls("シートまとめてコピー").Delete
Application.CommandBars("Worksheet Menu Bar").Controls("outputPDF").Delete
Application.CommandBars("Worksheet Menu Bar").Controls("保存して閉じる").Delete

印刷設定・ブックリンクリストの作成・シートまとめてコピー・PDFOutput・保存して閉じるを追加します。

ZIP
全て同じファイルに解凍しないと使えません。






22:54:53
シートまとめてコピー

シートまとめてコピーのマクロです。
無題

左側(シート部)はThisworkbook指定をしています。使うブックにインポートして使って下さい。



23:00:59
Sub outputPDF()
Application.ScreenUpdating = False
Dim fileName As String
fileName = ThisWorkbook.Path & "\" & ActiveSheet.Name & ".pdf"

Dim ws As Worksheet
Dim zzz
ReDim zzz(ActiveWindow.SelectedSheets.Count - 1)
Dim i As Long
i = 0
For Each s In ActiveWindow.SelectedSheets
zzz(i) = s.Name
i = i + 1
Next
For Each ws In Worksheets(zzz)

With ws.PageSetup

.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.CenterHorizontally = True
.TopMargin = Application.CentimetersToPoints(1)
.BottomMargin = Application.CentimetersToPoints(1)

End With

Next ws

Worksheets(zzz).Select
Activesheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:=fileName
Application.ScreenUpdating = True
End Sub


シート名でPDFを作成してくれます。
メールで送るときに楽ですわ。名前変えなくて良いので。。。



めっちゃ可愛いですわ。
邪エナガさんは伊賀栗好きそう(特に外側www)
2018/09/12
13:09:42
sub 名前定義コピー
Dim x As Long
Dim namae
x = 1
For Each ws In Worksheets
If ws.name = "名前の定義2" Then
ws.Delete
End If
Next
Worksheets.Add Before:=Worksheets(1)
ActiveSheet.name = "名前の定義2"
For Each namae In ActiveWorkbook.Names
ActiveSheet.Hyperlinks.Add Anchor:=Cells(x, 1), Address:=Cells(x, 1), SubAddress:="", _
TextToDisplay:=namae.name
x = x + 1
Next

With ActiveWorkbook.VBProject.VBComponents.Item(Worksheets("名前の定義2").CodeName).CodeModule
.insertlines 1, "Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)"
.insertlines 2, "On Error Resume Next"
.insertlines 3, "If InStr(ActiveCell, " & """" & "!" & """" & ") <> 0 Then"
.insertlines 4, "Worksheets(Left(ActiveCell, InStr(ActiveCell, " & """" & "'" & """" & ") - 1)).Range(Mid(ActiveCell, InStr(ActiveCell, " & """" & "!" & """" & ") + 1)).Copy"
.insertlines 5, "Else"
.insertlines 6, "dim namae"
.insertlines 7, "For Each namae In ActiveWorkbook.Names"
.insertlines 8, "If namae.name = ActiveCell.Value Then"
.insertlines 9, "Worksheets(Mid(Left(namae, InStrRev(namae, " & """" & "'" & """" & ") - 1), 3)).Range(Mid(namae, InStrRev(namae, " & """" & "!" & """" & ") + 1)).Copy"
.insertlines 10, "End If"
.insertlines 11, "Next"
.insertlines 12, "End If"
.insertlines 13, "On Error GoTo 0"
.insertlines 14, "End Sub"
End With
ActiveWorkbook.Save
DoEvents
ActiveWorkbook.Close
DoEvents
End Sub

もっと使いやすくなりました♪



誰も見た事のない変態フェチジャンルのバキュームベッド動画をまとめています。↓

バキュームベッド動画
23:13:07
Sub 選択範囲を移動する()
Dim senCSaigo As Long
senCSaigo = Selection.Columns.Count

Dim senCsaisyo As Long
senCsaisyo = Selection.Column

Dim senRSaigo As Long
senRSaigo = Selection.Rows.Count

Dim senRSaisyo As Long
senRSaisyo = Selection.Row
Range(Cells(senRSaisyo + senRSaigo, senCsaisyo), Cells(senRSaisyo + senRSaigo, senCsaisyo + senCSaigo - 1)).Select
End Sub

実行前・・・
実行前

実行後・・・
実行後

単純だけどすごく楽です。みんな大好きな楽~♪

めっちゃ可愛い//////


プロフィール

はなかな

Author:はなかな
FC2ブログへようこそ!

最新記事
最新コメント
月別アーカイブ
カテゴリ
フリーエリア
ランキング参加しています。 にほんブログ村 哲学・思想ブログ エホバの証人へ にほんブログ村 にほんブログ村 本ブログ 読書日記へ にほんブログ村 にほんブログ村 音楽ブログへ にほんブログ村
音楽(J-POP) ブログランキングへ
小説(読書感想) ブログランキングへ
キリスト教 ブログランキングへ
ブログランキング ブログ王ランキングに参加中!
検索フォーム
RSSリンクの表示
リンク
このブログをリンクに追加する
ブロとも申請フォーム

この人とブロともになる

QRコード
QR
FC2アフィリエイト