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

勉強ブログ

PR

X

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

1 2 3 4 5 6 >

マクロ

2018.05.31
XML
カテゴリ:マクロ
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) | コメントを書く
2017.12.30
カテゴリ:マクロ
'----------------------------------------------------------------------
'メインプログラム呼び出し
'----------------------------------------------------------------------
Sub a_call()
'----------------------------------------------------------------------
'ファイル名とシート名を入力
'----------------------------------------------------------------------
Dim bookName As String
Dim sheetName As String
bookName = "あああ.xlsx"
sheetName = "Sheet1"
'----------------------------------------------------------------------
'呼び出して、エクセルシートへ代入
'----------------------------------------------------------------------
Workbooks("あああ.xlsx").Worksheets("Sheet2").Range("A1:BYE10000") = get_Shapes_Property(bookName, sheetName)
'----------------------------------------------------------------------
'完了のメッセージ
'----------------------------------------------------------------------
MsgBox "END"
End Sub
'以下、メイン↓↓↓↓
'----------------------------------------------------------------------
'概要=ファイル名とシート名をもとに図形一覧を取得する
'引数=ファイル名+シート名
'戻値=図形のプロパティ一覧(バリアント型)
'備考=格納する配列は動的
'↓呼び出し元サンプル↓
'----------------------------------------------------------------------
'Sub a_call()
'Dim bookName As String
'Dim sheetName As String
'bookName = "あああ.xlsx"
'sheetName = "Sheet1"
'Workbooks("あああ.xlsx").Worksheets("Sheet2").Range("A1:BYE10000") = get_Shapes_Property(bookName, sheetName)
'MsgBox "END"
'End Sub
'----------------------------------------------------------------------
Public Function get_Shapes_Property(bookName As String, sheetName As String) As Variant
Dim obj As Object
Dim lists() As String
'----------------------------------------------------------------------
'ヘッダ部分(汎用性確保のため省略)
'----------------------------------------------------------
'ReDim Preserve lists(12, 0) As String
'lists(0, 0) = "Book"
'lists(1, 0) = "Sheet"
'lists(2, 0) = "AutoShapeType"
'lists(3, 0) = "vlookup"
'lists(4, 0) = "Text"
'lists(5, 0) = "Left"
'lists(6, 0) = "Top"
'lists(7, 0) = "Width"
'lists(8, 0) = "Height"
'lists(9, 0) = "TopLeftCell.Address"
'lists(10, 0) = "BottomRightCell.Address"
'lists(11, 0) = "Fill.ForeColor"
'lists(12, 0) = "color"
''----------------------------------------------------------
'listsの行数(ループ回数)をカウントする変数
'----------------------------------------------------------------------
Dim cnt
cnt = 0
'----------------------------------------------------------------------
'シート内の全ての図形の情報を取得してlistsに格納
'----------------------------------------------------------------------
For Each obj In Workbooks(bookName).Sheets(sheetName).Shapes
ReDim Preserve lists(12, cnt) As String
On Error Resume Next
lists(0, cnt) = Workbooks(bookName).Name
lists(1, cnt) = Workbooks(bookName).Worksheets(sheetName).Name
lists(2, cnt) = CStr(obj.AutoShapeType)
'lists(3, cnt)=Vlookup検索列
lists(4, cnt) = obj.TextFrame.Characters.Text
lists(5, cnt) = CStr(obj.Left)
lists(6, cnt) = CStr(obj.Top)
lists(7, cnt) = CStr(obj.Width)
lists(8, cnt) = CStr(obj.Height)
lists(9, cnt) = CStr(obj.TopLeftCell.Address(False, False))
lists(10, cnt) = CStr(obj.BottomRightCell.Address(False, False))
lists(11, cnt) = CStr(obj.Fill.ForeColor)
'lists(12, cnt)=前列のRGB値で塗りつぶし
cnt = cnt + 1
Next
'----------------------------------------------------------------------
'listsをget_Shapes_Propertyに代入
'----------------------------------------------------------------------
get_Shapes_Property = lists
'----------------------------------------------------------------------
End Function








最終更新日  2017.12.31 22:48:54
コメント(0) | コメントを書く
2017.12.27
カテゴリ:マクロ
Sub main_call()
Dim fl_name
Dim st_name
fl_name = "あああ.xlsx"
st_name = "Sheet1"
Call shapes_ungroup2(fl_name, st_name)
End Sub
'---------------------------------------------------------
'結合された図形の解除
'引数=ファイル名とシート名
'戻り値=無し
'編集中(なんかうまくいかない)
'---------------------------------------------------------
Sub shapes_ungroup2(fl_name, fl_sheet)
  Dim has_grp As Boolean  ''グループ化図形があることを示すフラグ
  Dim shp As Shape
  has_grp = False
  Do While has_grp = True
    For Each shp In Workbooks(fl_name).Worksheets(fl_sheet).Shapes
      
      If shp.Type = msoGroup Then
      Debug.Print shp.Type
        has_grp = True
        shp.Ungroup
         has_grp = False
      Else
      End If
      
    Next shp
  Loop
End Sub






最終更新日  2017.12.27 01:43:04
コメント(0) | コメントを書く
2017.12.26
カテゴリ:マクロ
'----------------------------------------------------------------------------------------------------
'概要=マトリクスの要素一覧を返す関数
'----------------------------------------------------------------------------------------------------
'引数=開始セル/終了セル
'----------------------------------------------------------------------------------------------------
'戻値=指定された範囲のセルのアドレス一覧(2次元配列)
'----------------------------------------------------------------------------------------------------
'↓↓↓↓呼び出し元サンプル↓↓↓↓
'Dim start_cell(0, 1)
'Dim end_cell(0, 1)
'start_cell(0, 0) = 開始セルのX軸値
'start_cell(0, 1) = 開始セルのY軸値
'end_cell(0, 0)  = 終了セルのX軸値
'end_cell(0, 1)  = 終了セルのY軸値
'------------------------------------
Function list_matrix(start_cell As Variant, end_cell As Variant) As Variant
'要素一覧を格納する変数の行数を計算
Dim row_number As Long
row_number = Abs(end_cell(0, 0) - start_cell(0, 0) + 1) * Abs(end_cell(0, 1) - start_cell(0, 1) + 1)
row_number = row_number - 1
'セルの範囲全てを変数に格納
Dim cells_area As Range
Set cells_area = ActiveSheet.Range(Cells(start_cell(0, 0), start_cell(0, 1)), Cells(end_cell(0, 0), end_cell(0, 1)))
'対象のセル(1セル)を格納する変数を宣言
Dim aimed_cells As Range
'要素一覧を格納する(配列)を宣言
ReDim list_matrix_inner(row_number, 1)
'セルの範囲全てを1セルずつ配列に格納
Dim row_row
row_row = 0
For Each aimed_cells In cells_area
list_matrix_inner(row_row, 0) = aimed_cells.Cells.row
list_matrix_inner(row_row, 1) = aimed_cells.Cells.column
row_row = row_row + 1
Next aimed_cells
list_matrix = list_matrix_inner
End Function






最終更新日  2017.12.31 00:23:13
コメント(0) | コメントを書く
2017.12.11
カテゴリ:マクロ
Function read_variant(start_cell As Variant, end_cell As Variant, column As Long, row As Long, value As String) As Variant
'概要=指定した範囲(マトリクス)から、その値とx/yの値を読み込んで、配列に格納する
'引数=読み込む範囲
'引数=x/yのキー行/列
'戻り値=配列(値/xのキー/yのキー)
End Function
Sub call_list_matrix()
Dim start_cell(0, 0)
'スタートセルのアドレスを代入
start_cell(0, 0) = 2
start_cell(0, 1) = 2
Dim end_cell(0, 0)
'エンドセルのアドレスを代入
start_cell(0, 0) = 3
start_cell(0, 1) = 4
Call list_matrix(start_cell, end_cell)
End Sub
Function list_matrix(start_cell As Variant, end_cell As Variant) As Variant
'マトリクスの要素一覧を返す関数
End Function









最終更新日  2017.12.11 23:24:34
コメント(0) | コメントを書く
カテゴリ:マクロ
Sub filter(filter_area)
'引数=フィルタ範囲(例:"A1:B9")
'A1:A9セルにフィルターをかけ、1行目にその日の日付で絞り込みをかける
Dim date_today
date_today = RTrim(Date)
'フィルター範囲の設定 + 絞り込み
ActiveSheet.Range(filter_area).AutoFilter Field:=1, Criteria1:=date_today
Debug.Print date_today
End Sub







最終更新日  2017.12.11 00:28:38
コメント(0) | コメントを書く
2017.12.10
カテゴリ:マクロ
Sub clipboard()
    '前提:ユーザーフォームを追加
    'A1セルにクリップボードをペースト
    ActiveSheet.Paste Destination:=Range("A1")
    
    'B1セルの値を取得し、クリップボードに格納
    Dim buf As String
    buf = ActiveSheet.Range("B1")
    With New MSForms.DataObject
        .SetText buf      '変数の値をDataObjectに格納する
        .PutInClipboard   'DataObjectのデータをクリップボードに格納する
    End With
     
    'クリップボードの値をC1セルに格納
    'ActiveSheet.Paste Destination:=Range("C1")
End Sub







最終更新日  2017.12.10 17:41:39
コメント(0) | コメントを書く

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

1 2 3 4 5 6 >


© Rakuten Group, Inc.