memo



カテゴリ:[ PC/ネット/モバイル ]


7件の内、新着の記事から10件ずつ表示します。


[7] graph

投稿者: memo 投稿日:2014年 5月14日(水)21時31分38秒 em119-72-197-117.pool.e-mobile.ne.jp  通報   返信・引用

Public GV_1 As Variant
Public GV_2 As Variant
Public GV_3 As Variant
Public GV_4 As Variant
''
''
Sub S00_graph_src_update()

  Application.Calculation = xlCalculationManual

  Dim col_chart As Collection
  Set col_chart = F_graph_select()

  Call S_get_graph_formula(col_chart)

  Application.Calculation = xlCalculationAutomatic

End Sub
Sub S_get_graph_formula _
  (col_chart As Collection _
  )

  Dim rng_temp As Range
  Set rng_temp = F_temp_cell()

  Dim i As Chart
  Dim j As Series
  For Each i In col_chart
    For Each j In i.SeriesCollection

      rng_temp.Formula = Replace(j.Formula, "=SERIES", "=XSERIES")
      rng_temp.Calculate ''Formula Evaluate
      Call S_src_resize(j, GV_2, GV_3)

    Next j
  Next i

  rng_temp.Value = Empty
  Set rng_temp = Nothing


End Sub


Function F_graph_select() As Collection

  Dim col_chart As Collection
  Set col_chart = New Collection

  If (Not (ActiveChart Is Nothing)) Then
  '' 特定のグラフを選択中
    col_chart.Add Item:=ActiveChart
    Set F_graph_select = col_chart
    Exit Function
  End If

  Select Case TypeName(Selection)
    Case "DrawingObjects"
      '' 複数のオブジェクト選択中
      Dim j As Variant
      For Each j In Selection
        If (TypeName(j) = "ChartObject") Then
          col_chart.Add Item:=j.Chart
        End If
      Next j

    Case Else
      '' それ以外、現在のシート内の全グラフを対象とする。
      Dim i As Integer
      For i = 1 To (ActiveSheet.ChartObjects.Count)
        col_chart.Add Item:=ActiveSheet.ChartObjects(i).Chart
      Next i

  End Select 'TypeName(Selection)

  Set F_graph_select = col_chart

End Function



Sub S_make_temp_shape _
  (obj_temp As Object _
  , Optional lng_r_pos As Long = 10 _
  , Optional lng_c_pos As Long = 20 _
  , Optional lng_r_size As Long = 100 _
  , Optional lng_c_size As Long = 200 _
  )

  Set obj_temp = ActiveSheet.Shapes.AddTextbox _
      (msoTextOrientationHorizontal _
      , lng_c_pos _
      , lng_r_pos _
      , lng_c_size _
      , lng_r_size _
      ).DrawingObject

'   ActiveSheet.Shapes.Range(Array("TextBox 4")).Formula = "=$E$6"
'

End Sub

Function XSERIES _
  (arg1 As Variant _
  , arg2 As Variant _
  , arg3 As Variant _
  , arg4 As Variant _
  ) As Integer

  If (TypeName(arg1) = "Range") Then
    Set GV_1 = arg1
  Else
    GV_1 = arg1
  End If

  If (TypeName(arg2) = "Range") Then
    Set GV_2 = arg2
  Else
    GV_2 = arg2
  End If

  If (TypeName(arg3) = "Range") Then
    Set GV_3 = arg3
  Else
    GV_3 = arg3
  End If

  If (TypeName(arg4) = "Range") Then
    Set GV_4 = arg4
  Else
    GV_4 = arg4
  End If

  XSERIES = Empty

End Function
Function F_temp_cell(Optional ws As Worksheet = Nothing) As Range

  Dim rng_temp As Range

  If (ws Is Nothing) Then
    Set ws = ActiveSheet
  End If

  With ws
    Set rng_temp = .Range("A1").SpecialCells(xlCellTypeBlanks)(1)
  End With 'ws

  Set F_temp_cell = rng_temp

End Function


Sub S_src_resize _
  (line As Series _
  , V_time As Variant _
  , V_data As Variant _
  )

  Dim rng_time As Range
  Dim rng_data As Range
  Dim str_arg1 As String
  Dim str_arg2 As String
  Dim str_arg3 As String

  If (TypeName(V_time) = "Range") Then
    Set rng_time = V_time
  Else
    Exit Sub
  End If

  If (TypeName(V_data) = "Range") Then
    Set rng_data = V_data
  Else
    Exit Sub
  End If

  If (rng_time.Rows.Count <> rng_data.Rows.Count) Then
    Exit Sub
  End If

  Set rng_time = F_resize_last_row(rng_time)
  Set rng_data = F_resize_last_row(rng_data)


  If (TypeName(GV_1) = "Range") Then
    str_arg1 = "'" & GV_1.Parent.Name & "'!" & GV_1.Address
  Else
    str_arg1 = """" & GV_1 & """"
  End If

  str_arg2 = "'" & rng_time.Parent.Name & "'!" & rng_time.Address
  str_arg3 = "'" & rng_data.Parent.Name & "'!" & rng_data.Address

  line.Formula = "=SERIES" _
    & "(" & str_arg1 _
    & "," & str_arg2 _
    & "," & str_arg3 _
    & "," & GV_4 _
    & ")"


End Sub

Function F_resize_last_row _
  (rng_target As Range _
  ) As Range

  With rng_target.Parent '' Sheet
    Set F_resize_last_row = .Range _
      (.Cells(rng_target.Row, rng_target.Column) _
      , .Cells(.Rows.Count, (rng_target.Column + rng_target.Columns.Count - 1)).End(xlUp) _
      )
  End With '' rng_target.Parent '' Sheet

End Function




[6] anc

投稿者: memo 投稿日:2014年 4月23日(水)06時17分25秒 em119-72-198-221.pool.e-mobile.ne.jp  通報   返信・引用

Public GV_col As Collection

Sub S_11()

  Application.Calculation = xlCalculationManual

  F_get_anc

  Application.Calculation = xlCalculationAutomatic

End Sub
Function F_get_anc _
  ( _
  ) As Variant

  Set GV_col = New Collection

  Selection.Calculate

  Set F_get_anc = GV_col

End Function
Function F_anc2 _
  (ParamArray V_opt() As Variant _
  ) As Variant

  GV_opt = V_opt

  Dim str_adr As String
  str_adr = Application.Caller.Address(False, False, xlA1, External:=True)

  GV_col.Add Key:=str_adr, Item:=V_opt

  F_anc2 = UBound(V_opt)


End Function



[5] 2xls

投稿者: memo 投稿日:2014年 2月 9日(日)16時01分20秒 em119-72-193-203.pool.e-mobile.ne.jp  通報   返信・引用

function [] = mat2xls( char_matfile )

  load(char_matfile);
  [ char_path, char_name ] = fileparts(char_matfile);
  char_output = strcat(char_name, '.xls');

  cell_var_list = who('-file', char_matfile );
  for f1 = 1:numel(cell_var_list)
    eval( sprintf('str_data = %s ;', cell_var_list{f1} ) );

    str_xls_var = F_xlsvar_build(str_data);

  end%for(f1)

  cell_sheet_list = fieldnames(str_xls_var);
  for f2 = 1:numel(cell_sheet_list)

%   dlmwrite ...
%     ( char_output ...
%     , str_xls_var.( cell_sheet_list{f2} ).head ...
%     , '-append' ...
%     , 'delimiter', ',' ...
%     , 'precision', '%s' ...
%     );

    xlswrite ...
      ( char_output ...
      , str_xls_var.( cell_sheet_list{f2} ).value ...
      , '-append' ...
      , 'delimiter', ',' ...
      , 'roffset', 25 ...
      );

  end%for(f2)

end%function%mat2xls
%=============================================
function [str_xls_var] = F_xlsvar_build( str_data )
   Pint_r_pos_name = 14;
   Pint_r_pos_rate = 16;
   Pint_r_pos_data = 26;

   int_sheet_count = numel(str_data.X);

   for f1 = 1:int_sheet_count
     char_rate =  str_data.X(f1).Rate ;
     char_sheet = strcat('Sheet_', char_rate);
     int_r_size_data = size( str_data.X(f1).Data, 1);
     str_xls_var.(char_sheet).value(1:int_r_size_data, 1) = str_data.X(f1).Data ;

     str_c_pos.(char_sheet) = 1 ;
   end%for(f1)


   for f2 = 1:numel(str_data.Y)
     char_rate = str_data.Y(f2).Rate;
     char_sheet = strcat('Sheet_', char_rate);
     int_r_size_data = size( str_data.Y(f2).Data, 1);
     str_c_pos.(char_sheet) = str_c_pos.(char_sheet) + 1 ;
%       horzcat

     str_xls_var.(char_sheet).head( Pint_r_pos_name  , str_c_pos.(char_sheet)) = str_data.Y(f2).Name ;
     str_xls_var.(char_sheet).head( Pint_r_pos_rate  , str_c_pos.(char_sheet)) = str_data.Y(f2).Rate ;

     str_xls_var.(char_sheet).value(1:int_r_size_data, str_c_pos.(char_sheet)) = str_data.Y(f2).Data ;

   end%for(f2)

end%function%F_xlsvar_build



[4] Ctrl+F find 検索

投稿者: mori 投稿日:2013年11月17日(日)10時36分51秒 em119-72-198-246.pool.e-mobile.ne.jp  通報   返信・引用

Option Explicit
Sub S_find_test()

  Dim rng_find_result() As Range

  Call S_find(rng_find_result, "小_田", Range("A1:Z255"))

  MsgBox UBound(rng_find_result)

End Sub

Sub S_find _
  (rng_find_result() As Range _
  , str_keyword As String _
  , rng_find_area As Range _
  )

  ReDim rng_find_result(0)


' MatchCase:=True 大文字小文字を区別する。
' LookAt:=xlWhole 完全マッチ
' MatchByte:=True 半角と全角を区別する。

  With rng_find_area

    Set rng_find_result(0) = .Find _
     (What:=str_keyword _
     , LookIn:=xlValues _
     , LookAt:=xlWhole _
     , SearchOrder:=xlByColumns _
     , SearchDirection:=xlNext _
     , MatchCase:=True, _
     SearchFormat:=False _
     )

    If (rng_find_result(0) Is Nothing) Then
      Exit Sub
    End If

    Dim i As Integer: i = 0
    Do
      Dim rng_temp As Range
      Set rng_temp = .FindNext(rng_find_result(i))

      If (rng_temp.Address = rng_find_result(0).Address) Then
        Exit Do
      End If

      i = i + 1
      ReDim Preserve rng_find_result(i)
      Set rng_find_result(i) = rng_temp

    Loop


  End With 'rng_find_area

End Sub



[3] sub

投稿者: mori 投稿日:2013年 7月30日(火)04時27分20秒 em119-72-193-197.pool.e-mobile.ne.jp  通報   返信・引用

Option Explicit
Sub S00_main()

  Dim obj_xls As Object
  Dim bool_result As Boolean
  Dim obj_open_book As Object
  Const str_db_sheet As String = "Sheet_DB"
  Const str_db_range As String = "B2:E10"
  Dim rng_db As Range
  Dim rng_write_cell As Range


  Set obj_xls = Excel.Application

  Call S_file_open_gui _
    (bool_result _
    , obj_xls _
    , obj_open_book _
    )

  If (bool_result = False) Then
    GoTo L_end:
    Exit Sub
  End If


  Set rng_db = obj_xls.Workbooks(obj_open_book.Name).Worksheets(str_db_sheet).Range(str_db_range)
  Set rng_write_cell = ThisWorkbook.ActiveSheet.Range("A1:A21")

  Call S_db_ref(rng_db, rng_write_cell)


L_end:
  Set obj_open_book = Nothing
  Set obj_xls = Nothing


End Sub


Sub S_file_open_gui _
  (bool_result As Boolean _
  , obj_xls As Object _
  , obj_open_book As Object _
  )

  Dim V_open_file As Variant
  Dim obj_fso As Object
  Set obj_fso = CreateObject("Scripting.FileSystemObject")

  bool_result = True


  V_open_file = obj_xls.GetOpenFilename("Microsoft Excel Book,*.xls?")

  If (V_open_file = False) Then
    bool_result = False
    GoTo L_end:
  End If

  Set obj_open_book = obj_fso.getfile(V_open_file)


  If (F_book_exist(obj_xls.Workbooks, obj_open_book.Name) = True) Then
    '既にOpenしている場合
    MsgBox obj_open_book.Name & "が既にOpenしています。"
    bool_result = False
    GoTo L_end:

  End If

  obj_xls.Workbooks.Open _
    Filename:=obj_open_book.Path _
    , ReadOnly:=True



L_end:
  Set obj_fso = Nothing

End Sub
Sub S_db_ref _
  (rng_db As Range _
  , rng_write_cell As Range _
  )

  Dim rng_r_title As Range
  Set rng_r_title = F_set_r_title(rng_db)

  Dim i As Range
  For Each i In rng_write_cell
    Dim str_type As String
    Dim int_r_size As Integer
    Dim int_c_size As Integer

    If (Len(i.Value) = 0) Then
      GoTo L_next:

    End If

    str_type = WorksheetFunction.VLookup(i.Value, rng_db, 2, False)
    int_r_size = F_r_size_search(i, rng_db)
    int_c_size = F_c_size_search(i, rng_db)

    i.Offset(0, 1).Value = str_type & ":" & int_r_size & ":" & int_r_size

L_next:
  Next i




End Sub
Function F_book_exist _
  (obj_book As Object _
  , str_word As String _
  ) As Boolean

  F_book_exist = False
  Dim i As Variant
  For Each i In obj_book
    If (i.Name = str_word) Then
      F_book_exist = True
      Exit For
    End If
  Next i


End Function
Private Function F_r_size_search _
  (rng_crnt_cell As Range _
  , rng_db As Range _
  ) As Integer

  Dim int_last_cell As Integer
      int_last_cell = rng_db.Parent.Cells(Rows.Count, rng_db.Column).End(xlUp).Row

  Dim int_r As Integer
  If (rng_crnt_cell.Row = int_last_cell) Then
   'DBから参照
   int_r = WorksheetFunction.VLookup(rng_crnt_cell.Value, rng_db, 3, False)

  Else
    int_r = F_empty_count_r(rng_crnt_cell)

    If (1) Then '2のN乗に丸め込む
     int_r = F_floor_power(int_r)
    End If
  End If


  F_r_size_search = int_r

End Function
Function F_floor_power _
  (int_r As Integer _
  , Optional ByVal int_crct_val As Integer = 1 _
  ) As Integer
  'FLOOR関数の指定値のN乗で切り捨てる版

  Dim int_next_val As Integer
  int_next_val = int_crct_val * 2
  If (int_r >= int_next_val) Then
    int_crct_val = F_floor_power(int_r, int_next_val)
  End If

  F_floor_power = int_crct_val

End Function
Private Function F_c_size_search _
  (rng_crnt_cell As Range _
  , rng_db As Range _
  ) As Integer

  Dim int_c As Integer

  If (Len(rng_crnt_cell.Offset(0, 1).Value) > 0) Then
    'Ctrl + →
    int_c = rng_crnt_cell.End(xlToRight).Column

  Else
    int_c = WorksheetFunction.VLookup(rng_crnt_cell.Value, rng_db, 4, False)

  End If

  F_c_size_search = int_c

End Function


Function F_empty_count_r _
  (rng_crnt_cell As Range _
  , Optional ByVal int_r As Integer = 1 _
  , Optional int_limit As Integer = 512 _
  ) As Integer

  If (int_r >= int_limit) Then 'isempty
    F_empty_count_r = int_limit
    Exit Function
  End If

  If (Len(rng_crnt_cell.Offset(int_r, 0).Value) = 0) Then 'isempty
    int_r = F_empty_count_r(rng_crnt_cell, (int_r + 1))
  End If

  F_empty_count_r = int_r

End Function


Function F_set_r_title _
  (rng_db As Range _
  ) As Range

  Dim lng_u As Long
' Dim int_l As Integer
  Dim lng_d As Long
' Dim int_r As Integer

  lng_u = rng_db.Row
' int_l = rng_db.Column
  lng_d = lng_u + rng_db.Rows.Count - 1
' int_r = int_l + rng_db.Columns.Count - 1

  Set F_set_r_title = rng_db.Resize(lng_d, 1)

End Function




[2] vba

投稿者: mori 投稿日:2013年 7月23日(火)06時32分42秒 em119-72-193-33.pool.e-mobile.ne.jp  通報   返信・引用

Sub S_crct_value_warap()

Call S_crct_value(Selection)

End Sub
Sub S_crct_value(rng_data As Range)

  Dim bool_c_mode As Boolean: bool_c_mode = False
  Dim bool_r_mode As Boolean: bool_r_mode = False
  Dim bool_crct_head As Boolean

  '縦方向補完モードか横方向補完モードか確認
  If (rng_data.Columns.Count = 3) Then
    If ((F_range_is_double(rng_data.Columns(1).Cells) = True) _
    And (F_range_is_double(rng_data.Columns(3).Cells) = True) _
    ) Then
      bool_c_mode = True
      bool_crct_head = IsEmpty(rng_data.Columns(2).Cells(1, 1))
    End If
  End If

  If (rng_data.Rows.Count = 3) Then
    If ((F_range_is_double(rng_data.Rows(1).Cells) = True) _
    And (F_range_is_double(rng_data.Rows(3).Cells) = True) _
    ) Then
      bool_r_mode = True
      bool_crct_head = IsEmpty(rng_data.Rows(2).Cells(1, 1))
    End If
  End If


  Dim int_result As Integer
  If ((bool_r_mode And bool_c_mode) = True) Then
    int_result = MsgBox("縦補完-->Yes, 横補完-->No", vbYesNo, "Select Mode")
    'yes6 no7
    Select Case int_result
      Case vbYes
        bool_r_mode = True
        bool_c_mode = False
      Case vbNo
        bool_r_mode = False
        bool_c_mode = True
      Case Else
        bool_r_mode = False
        bool_c_mode = False
    End Select
  End If


  If (bool_r_mode = True) Then
    Call S_crct _
      (rng_data.Rows(1).Cells _
      , rng_data.Rows(2).Cells _
      , rng_data.Rows(3).Cells _
      , bool_crct_head _
      )
  End If

  If (bool_c_mode = True) Then
    Call S_crct _
      (rng_data.Columns(1).Cells _
      , rng_data.Columns(2).Cells _
      , rng_data.Columns(3).Cells _
      , bool_crct_head _
      )

  End If



  If ((bool_r_mode = False) _
  And (bool_c_mode = False) _
  ) Then
    MsgBox "セルの選択範囲を3×? か ?×3にしてマクロ実行してください" & vbNewLine _
      & "現在の選択サイズ-->縦=" & rng_data.Rows.Count & ", 横=" & rng_data.Columns.Count

  End If

End Sub

Function F_range_is_double(rng_data As Range) As Boolean
'Range内のセルが全て数値が入っているか/いないか

  Dim bool_result As Boolean: bool_result = True

  Dim i As Variant
  For Each i In rng_data
    If (IsNumeric(i.Value) = True) Then
    Else
      bool_result = False
      Exit For
    End If
  Next i

  F_range_is_double = bool_result

End Function

Sub S_crct _
  (rng_1 As Range _
  , rng_2 As Range _
  , rng_3 As Range _
  , bool_crct_head As Boolean _
  )

  Dim w_crct_ratio As Double

  If (bool_crct_head = True) Then
    '50%
    w_crct_ratio = 0.5
    rng_2.Cells(1, 1).Value = ((rng_3.Cells(1, 1).Value - rng_1.Cells(1, 1).Value) * w_crct_ratio) + rng_1.Cells(1, 1).Value

  Else
    w_crct_ratio = F_get_ratio _
      (rng_1.Cells(1, 1).Value _
      , rng_2.Cells(1, 1).Value _
      , rng_3.Cells(1, 1).Value _
      )

  End If


  If (rng_2.Count < 2) Then
    Exit Sub
  End If

  Dim i As Integer
  For i = 2 To rng_2.Count
    rng_2(i).Value = ((rng_3(i).Value - rng_1(i).Value) * w_crct_ratio) + rng_1(i).Value
  Next i

End Sub


Function F_get_ratio _
  (w_a As Double _
  , w_x As Double _
  , w_b As Double _
  ) As Double

  Dim w_diff_a_x As Double
  Dim w_diff_a_b As Double

  w_diff_a_x = w_x - w_a
  w_diff_a_b = w_b - w_a

  F_get_ratio = w_diff_a_x / w_diff_a_b

End Function

Sub S_db_inport_wrap()

Call S_db_inport(Selection)

End Sub
Sub S_db_inport(rng_data As Range)


  Dim rng_r_head As Range
  Dim rng_c_head As Range
  Set rng_r_head = rng_data.CurrentRegion.Rows(1)
  Set rng_c_head = rng_data.CurrentRegion.Columns(1)


  Dim i As Integer
  For i = 2 To rng_r_head.Count

  Next i


End Sub



[1] 掲示板が完成しましたキラキラ

投稿者: teacup.運営 投稿日:2013年 7月23日(火)06時29分59秒 em119-72-193-33.pool.e-mobile.ne.jp  通報   返信・引用

ご利用ありがとうございます。

teacup.掲示板は
ダイヤスレッド作り放題右上
ダイヤ画像・動画・音楽の投稿OK
ダイヤケータイ絵文字が使えるv▽v
ダイヤRSS対応ヒラメイタ!
ダイヤかわいいケータイテンプレハートx2

足跡足あと帳はコチラ
スレッド内容は管理画面内「スレッドの管理」から編集できます。


レンタル掲示板
7件の内、新着の記事から10件ずつ表示します。

お知らせ · よくある質問(FAQ) · お問合せ窓口

© GMO Media, Inc.