000000 ランダム
 ホーム | 日記 | プロフィール 【フォローする】 【ログイン】

勉強ブログ

PR

X

全151件 (151件中 1-10件目)

1 2 3 4 5 6 ... 16 >

2018.05.31
XML
カテゴリ:カテゴリ未分類
Option Explicit

' 指定したフォルダ内のファイルの一覧を取得
Sub Display_Directory()
Const cnsTitle = "フォルダ内のファイル名一覧取得"
Const cnsDIR = "\*.*"
Dim xlAPP As Application
Dim THIS_WORKBOOK_NAME As String

Dim strPathName As String, vntPathName As Variant
Dim vntSheet As Variant
Dim strFileName As String
Dim line As Long

THIS_WORKBOOK_NAME = ThisWorkbook.Name
'開始行番号
line = 2

Set xlAPP = Application
' InputBoxでフォルダ指定を受ける
vntPathName = xlAPP.InputBox("参照するフォルダ名を入力して下さい。", _
cnsTitle, CurDir)
If VarType(vntPathName) = vbBoolean Then Exit Sub
strPathName = vntPathName
' フォルダの存在確認
If Dir(strPathName, vbDirectory) = "" Then
MsgBox "指定のフォルダは存在しません。", vbExclamation, cnsTitle
Exit Sub
End If

' 先頭のファイル名の取得
strFileName = Dir(strPathName & cnsDIR, vbNormal)
' ファイルが見つからなくなるまで繰り返す
Do While strFileName <> ""

' Excelのみ対象
If (InStr(1, strFileName, ".xls", vbTextCompare)) <> 0 And strFileName <> THIS_WORKBOOK_NAME Then


Workbooks.Open Filename:= _
vntPathName & "\" & strFileName

For Each vntSheet In Sheets
'ファイル名を1列目にセット
Workbooks(1).Sheets(1).Cells(line, 1).Value = strFileName
Workbooks(1).Sheets(1).Cells(line, 2).Value = vntSheet.Name
' 行を加算
line = line + 1
Next vntSheet

ActiveWindow.Close

End If

' 次のファイル名を取得
strFileName = Dir()
Loop

Call MsgBox("ファイル・シート名出力が完了しました", vbOKOnly, "終了メッセージ")
End Sub






最終更新日  2018.05.31 14:46:55
コメント(0) | コメントを書く


カテゴリ:マクロ
Sub スクロール位置調整()
Dim ws As Worksheet

For Each ws In Worksheets
ws.Select
Range("A1").Select
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
ActiveWindow.Zoom = 100
Next ws
'Worksheets(1).Range("A1").Select
Worksheets(1).Select
Range("A1").Select
End Sub






最終更新日  2018.05.31 12:06:50
コメント(0) | コメントを書く
2018.05.30

tst

カテゴリ:マクロ
'呼び出し元
'内容=取り消し線のあるセルの値をクリアし、その行を黄色で塗る
'対象=Range(Cells(1, 1), Cells(1000, 100))
'空白行で取り消し線のあったセルの塗りつぶしは行わない
Function clr_value()
Dim tst As Range

For Each tst In ThisWorkbook.ActiveSheet.Range(Cells(1, 1), Cells(1000, 100))
Call del_strkthr_range(tst)
Next



For Each tst In ThisWorkbook.ActiveSheet.Range(Cells(1, 1), Cells(1000, 100))
tst.Value = del_strkthr_char(tst)
Next

MsgBox "End"
End Function




'呼び出し先
Function del_strkthr_range(cell As Range)
If cell.Font.Strikethrough = True And cell.Value <> "" Then
cell.Value = ""
If WorksheetFunction.CountA(Rows(cell.Row)) = 0 Then
Rows(cell.Row).Interior.ColorIndex = 6
Else
End If
Else
End If


End Function


'呼び出し先
Function del_strkthr_char(cell As Range)
Dim count As Integer
Dim i As Integer
Dim char As Characters
Dim result As String
count = Len(cell.Text)
For i = 1 To count
Set char = cell.Characters(i, 1)
If Not char.Font.Strikethrough Then
result = result + char.Text
End If
Next
del_strkthr_char = result
End Function















最終更新日  2018.05.30 15:05:30
コメント(0) | コメントを書く
2018.05.02
カテゴリ:マクロ
'プルダウンメニューを選択する
Sub SelectPulldownMenu()
    Dim objIE As Object
 
    'IE起動
    Set objIE = CreateObject("InternetExplorer.Application")
    objIE.Visible = True
 
    'お問い合わせフォームに接続
    objIE.navigate "https://form1.fc2.com/form/?id=627794"
 
    'IEを待機
    Call IEWait(objIE)
 
    '3秒停止
    Call WaitFor(3)
 
    'プルダウンメニューを選択
    objIE.Document.getElementsbyname("aetas")(0).SelectedIndex = "2"
    'objIE.Document.getElementsbyname("aetas")(0).Value = "1"
    objIE.Document.getElementsbyname("name")(0).Value = "長谷川"
    objIE.Document.getElementsbyname("text1")(0).Value = "あああああああああああああああああああああああああああああああ"
    objIE.Document.getElementsbyname("homepage")(0).Value = "https://form1.fc2.com/form/?id=627794"
    objIE.Document.getElementsbyname("mail")(0).Value = "hasegawa.yuuhi@gmail.com"
    'objIE.Document.getElementsbyname(ThisWorkbook.ActiveSheet.Range("B" & i))(0).Value = ThisWorkbook.ActiveSheet.Range("C" & i)
    'valueがあれば以下のように直接設定するほうがいい
    'objIE.Document.getElementById("aetas").value = "値"
     objIE.Document.getElementsbyname("gender")(0).Click
     objIE.Document.getElementsbyname("select1[]")(1).Checked = True
    
    
    '3秒停止
    Call WaitFor(3)
 
    'IE終了
    'objIE.Quit
 
    Set objIE = Nothing
End Sub
 
'IEを待機する関数
Function IEWait(ByRef objIE As Object)
    Do While objIE.Busy = True Or objIE.readyState <> 4
        DoEvents
    Loop
End Function
 
'指定した秒だけ停止する関数
Function WaitFor(ByVal second As Integer)
    Dim futureTime As Date
 
    futureTime = DateAdd("s", second, Now)
    While Now < futureTime
       DoEvents
    Wend
End Function






最終更新日  2018.05.02 07:54:32
コメント(0) | コメントを書く
2018.05.01
カテゴリ:マクロ
アクティブシートのB1=サイトのURL
アクティブシートのB3~B10000=要素の名前(name)
アクティブシートのC3~C10000=入れる値

Private Sub CommandButton1_Click()
    Dim IE As Object
 
    target = ThisWorkbook.ActiveSheet.Range("B1")
    Set IE = CreateObject("InternetExplorer.Application")
    With IE
        .Visible = True
        .Navigate target
     
        Do While .Busy = True Or .ReadyState <> 4
            DoEvents
        Loop
         Do While .Document.ReadyState <> "complete"
            DoEvents
        Loop
 
Dim mxrow
mxrow = ThisWorkbook.ActiveSheet.Range("B10000").End(xlUp).Row
            
 For i = 3 To mxrow
        .Document.getElementsByName(ThisWorkbook.ActiveSheet.Range("B" & i))(0).Value = ThisWorkbook.ActiveSheet.Range("C" & i)
 Next i
        .Document.forms(0).submit
    End With
End Sub






最終更新日  2018.05.01 22:02:34
コメント(0) | コメントを書く
2018.03.30
カテゴリ:マクロモジュール
概要:テキストファイルを新規作成する
引数:ファイルパス
戻値:
備考:ファイルを作成して格納するだけのプログラム(戻値としては返さない)
Sub createTxtfle(fle_path)
 Dim fso As Object
 
 Set fso = CreateObject("Scripting.FileSystemObject")
  fso.createtextfile (fle_path)
 
 Set fso = Nothing
End Sub






最終更新日  2018.03.30 20:40:01
コメント(0) | コメントを書く
2018.03.10
カテゴリ:マクロモジュール
概要:ワード内の全ての画面ショット(InlineShapes)の幅を統一するマクロ(縦横比固定のまま)
引数:幅
戻値:なし
備考:なし

Sub change_width(width)

For Each shp In ActiveDocument.InlineShapes
        shp.LockAspectRatio = msoTrue
        shp.width = width
Next

MsgBox "END"

End Sub







最終更新日  2018.03.10 20:24:03
コメント(0) | コメントを書く
2018.02.09
カテゴリ:マクロモジュール
'------------------------------------------------------------------
'概要=図形のグループ化を解除
'引数=ファイル名、シート名
'戻値=無し
'引数の型=文字型、文字型
'戻値の型=無し
'その他=PCの拡張子の有無設定により、ファイル指定が出来ない場合あり
'------------------------------------------------------------------
Sub shapes_ungroup(fl_name, fl_sheet)
Dim bGrp As Boolean, shp As Shape
'メインループ
Do
    bGrp = False 'グループ存在フラグをFalseで初期化
    '現在のシートの全てのオブジェクトでループ
    For Each shp In Workbooks(fl_name).Worksheets(fl_sheet).Shapes
        'グループ化されたオブジェクトの場合、グループ存在フラグをTrueにし、
        'グループを1階層だけ解除
        If shp.Type = msoGroup Then
            bGrp = True
            shp.ungroup 'グループ解除
        End If
    Next shp '次のオブジェクトへ
    'グループのオブジェクトが1つも見つからない場合は、メインループを終了する
    If bGrp = False Then
        Exit Do
    End If
Loop
End Sub







最終更新日  2018.02.09 19:26:09
コメント(0) | コメントを書く
2018.02.04
カテゴリ:マクロモジュール
'------------------------------------------------------------------
'概要=指定の大きさの一次元の空配列を作成して返す
'引数=配列の行数
'戻値=指定した行数の空配列
'引数の型=数値型
'戻値の型=配列型
'その他=呼び出し元で型指定なしで変数を作成し、その変数にこの関数で作成した配列を代入すれば指定した行数の配列が呼び出し元で出来る
'------------------------------------------------------------------
Function make_array_1d(row) As Variant
ReDim ary(row)
make_array_1d = ary
End Function






最終更新日  2018.02.04 17:46:12
コメント(0) | コメントを書く
2018.02.03
カテゴリ:マクロモジュール
'------------------------------------------------------------------
'概要=ファイルのコピー
'引数=コピー元パス、コピー先パス
'戻値=無し
'引数の型=文字型
'戻値の型=無し
'その他=パスはファイル名まで必要
'------------------------------------------------------------------
Sub fl_copy(from, dest)
FileCopy from, dest
End Sub







最終更新日  2018.02.03 21:51:16
コメント(0) | コメントを書く

全151件 (151件中 1-10件目)

1 2 3 4 5 6 ... 16 >


© Rakuten Group, Inc.