FC2ブログ
エホバの証人二世の、個人研究&趣味blogです。
2019/07«│ 2019/08| 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 31 »2019/09
文字色の変化のON/OFFが出来ます。文字サイズ文字サイズ:大文字サイズ:中文字サイズ:小
23:30:55
名前の定義のリンクリストを作ります。すごく難しいです。
ただ、作業しながらできるからいいかなって思っています!!!

Dim x As Long
Dim namae
x = 1
For Each ws In Worksheets
If ws.Name = "名前の定義" Then
ws.Delete
End If
Next
Worksheets.Add before:=Worksheets(1)
ActiveSheet.Name = "名前の定義"
For Each namae In ActiveWorkbook.Names
ActiveSheet.Hyperlinks.Add Anchor:=Cells(x, 1), Address:="", SubAddress:= _
namae.Name, TextToDisplay:=namae.Name
x = x + 1
Next
23:30:14


Sub ken()
Application.ScreenUpdating = False
Dim kensaku
kensaku = InputBox("検索したいテキストの入力")
Dim Shell, myPath
Set Shell = CreateObject("Shell.Application")
Set myPath = Shell.BrowseForFolder(&O0, "フォルダを選んでください", &H1 + &H10, "C:\")
If Not myPath Is Nothing Then MsgBox myPath.Items.Item.Path
Dim fso As FileSystemObject
Set fso = New FileSystemObject ' インスタンス化

Dim fl As Folder
Set fl = fso.GetFolder(myPath.Items.Item.Path) ' フォルダを取得
Dim f As File
For Each f In fl.Files
If InStr(fl.Files, kensaku) <> 0 Then
ListBox1.AddItem fl.Files
End If
Next

Set Shell = Nothing
Set myPath = Nothing
Application.ScreenUpdating = True
End Sub




7feb6_1604_e178b07bfd4873622403e7b6654c481b.jpg

コウペンちゃんって可愛いですよね。後こんなの買っちゃいました。



これのガチャガチャも可愛いです(笑)
これはブログ等のポイントで買いました。
最近買い物のほとんどはポイントですませてます。



これは一個百円。散財。
23:54:32
Sub Sample2()
Dim Shell, myPath
Set Shell = CreateObject("Shell.Application")
Set myPath = Shell.BrowseForFolder(&O0, "フォルダを選んでください", &H1 + &H10, "C:\")
If Not myPath Is Nothing Then MsgBox myPath.Items.Item.Path
Dim fso As FileSystemObject
Set fso = New FileSystemObject ' インスタンス化

Dim fl As Folder
Set fl = fso.GetFolder(myPath.Items.Item.Path) ' フォルダを取得
Dim i As Long
i = 1
Do Until Cells(i, 1) = ""
x = x + 1
Loop
Dim f As File
For Each f In fl.Files ' フォルダ内のファイルを取得
Cells(i, 1) = f.Name ' ファイルの名前 (Tips.txt) など

Cells(i, 1) = f.Path
i = i + 1
Next

Set Shell = Nothing
Set myPath = Nothing
End Sub


使いやすいんですよね~。ダブりの解除が出来たらさらに良いかなと思います。

23:28:59
おやすみ中にやる予定のこと、半分終りました💖
でも、会いたい人に会ったりしていないのでしないとなと思います。

作業はほぼ通常通りやってます。
今週からやること増えるから忙しくなりますが、頑張ります。
ニンニクで乗りきるよ。
あと蜂蜜しょうが✨
蜂蜜しょうがは夏バテ、疲れ、冷えに効果的なんです(^-^)

毎日2、3杯飲んでも大丈夫b

Const cnsDIR = "\*.xls*"
Dim strFilename As String
Dim GYO As Long ' 先頭のファイル名の取得
strFilename = Dir(TextBox1.text & cnsDIR, vbNormal)
' ファイルが見つからなくなるまで繰り返す
Do While strFilename <> ""
' 行を加算
ListBox1.AddItem strFilename
' 次のファイル名を取得
strFilename = Dir()
Loop

これいいね。Thisworkbookも使えるし。。。
2018/08/10
23:57:26
Sub 式のコピー()
Dim MaxRow As Long
Dim MaxCol As Long
Dim namae As String
Dim ws
Dim g As Variant
For Each ws In Worksheets
If InStr(ws.Name, " (") <> 0 Then
namae = Left(ws.Name, InStr(ws.Name, " (") - 1)
With Worksheet(namae).UsedRange
MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
MaxCol = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
End With
s = Range(Worksheets(namae).Range("a1"), Worksheets(namae).Cells(MaxRow, MaxCol)).Formula
Exit For
End If
Next
Dim k As Variant
Dim i As Long, j As Long
For Each ws In Worksheets

With ws.UsedRange
MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
MaxCol = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
End With
k = Range(ws.Range("a1"), ws.Cells(MaxRow, MaxCol))
For i = 1 To MaxRow
For j = 1 To MaxCol
If InStr(s(i, j), "=") <> 0 Then
k(i, j) = s(i, j)
End If
Next
Next
Range(ws.Range("a1"), ws.Cells(MaxRow, MaxCol)) = k
DoEvents
Next
End Sub

配列貼り付けた後、ファイルを開いた後、保存の後、ファイルを閉じる後、計算の後などにDoEventsを入れると動きやすいです。
少し、ですが。他の作業しながらでもマクロ動かせます。
プロフィール

はなかな

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

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

この人とブロともになる

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