Ichida.Coffee."ExcelVBA".

前ページ
次ページ

Excelの仕様を超えた桁数の数値計算【１÷９８０１の不思議】

不思議な答えの数値計算で、

１÷９８０１

これを計算すると答えは下になります（*^o^*）＜ 200桁!!

0.00010203040506070809101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979900

見れば分かると思いますが、

01・02・03・04・05・06・07・08・09・10・11・12･･･････

って感じで数字が続いてますね!!

これをExcelの数式で試しました。A1セルに"=1/9801"を入力して表示桁を増やしてみたら、

8以降は全部ゼロかい!!

仕方がないのでVBAで簡単なCodeを書いてみた。


Sub keisan()

  MsgBox 1 / 9801

End Sub

しかし･･･････････

まー、Excelの仕様だから仕方ないんですが･･･(-。-)y-゜゜゜ﾔﾚﾔﾚ

そこで、どうにかVBAで作ってみようと思いました。

数値を文字として扱えば、相当な桁数に対応出来ると思ったので!!

使用制限はありますが、以下はそのVBAです（*^_^*）

****************************************************************************


Option Explicit

Sub Sample()
  
'Ａ÷Ｂの計算【Excelの仕様以上の桁数表示】
'ただし、Ａ＜Ｂでそれぞれの値は整数であること!!
  
  Dim A     As Long
  Dim B     As Long
  Dim Keta  As Integer
  Dim I     As Integer
  Dim Ans   As String

'************************** Input_Data *******
    
    A = 1       '----- Ａ÷Ｂ の Ａの値(整数)
    B = 9801    '----- Ａ÷Ｂ の Ｂの値(整数)
    Keta = 200  '----- 少数以下の表示桁数

'※整数を扱って計算する仕様としてますので、
'　　　　少数を入力しても整数に置き換わります。
'*********************************************
      
      If A < B Then '-----仕様の検査(Ａ＜Ｂ)
        Ans = "0."
        A = A * 10
      Else
        GoTo EndSub
      End If

      For I = 1 To Keta
          If A / B < 0 Then
            A = A * 10
            Ans = Ans & "0"
          Else
            Ans = Ans & Int(A / B)
            A = 10 * (A - Int(A / B) * B)
          End If
      Next

MsgBox Ans
Range("a15") = Ans
Exit Sub

'--------------Error------------------
EndSub:
  Ans = "Error"
  MsgBox Ans

End Sub

****************************************************************************

これで、少数以下200を表示!!

と、目的は達成しましたが、なぜ"98"が飛ばされてるか疑問です。。。。

追記:冷静に考えたら98が飛ばされる理由がわかりました。97、98、99、100と続くならば、100が1くりあがって99を100にする。さらに1くりあがって98を99にする。そうすると98はとびますよね（*^_^*）

単一セルの設定値を獲得【API関数でINI操作】

"単一セルの設定値"とは「セルの書式設定」で設定できる全ての項目のことで、
タブ項目にある、表示形式、配置、フォント、罫線、塗りつぶし、保護のそれぞれで設定できるもののことです。

作った物を説明すると、以下２つ。

(Ａ)単一セルの設定値を獲得し、構成設定ファイル(INI)に書き出す処理。(セル文字・数式も含む)
(Ｂ)書き出されたINIを読み、任意のセルの設定値を変える処理。(セル文字・数式も含む)

Ｂの処理に関しては「セルの書式設定」のタブ項目別に設定値を与える事ができる。
例えば、配置とフォント要素の設定値変更････とか
数式と表示形式の変更････とか

Ａの処理ルーチンは"CellSettingINIWrit"で、Ｂの処理ルーチンは"CellSettingINIRead"
----------------------------------------
CellSettingINIWrit
【引数】
myRange → Range形式でセルを指定【例】ActiveSheet.Range ("B12")
iniFileName → String形式でINIの名前を指定【例】"D:\try.ini"
----------------------------------------
CellSettingINIRead
【引数】
IniSectionName → String形式でシート名とセルアドレスを"-"で繋いだ文字【例】"Sheet1-B2"
myRange　　　　→ Range形式でセルを指定【例】ActiveSheet.Range ("B12")
iniFileName 　→ String形式でINIの名前を指定【例】"D:\try.ini"
Qshikiatai 　 → Boolean形式で文字や数式を設定するかどうかのFlug(省略可能)
Qhyouji 　 → Boolean形式で表示形式を設定するかどうかのFlug(省略可能)
Qhaichi 　 → Boolean形式で配置要素を設定するかどうかのFlug(省略可能)
Qfont 　　→ Boolean形式でフォント要素を設定するかどうかのFlug(省略可能)
Qnuri 　　→ Boolean形式で塗りつぶし要素を設定するかどうかのFlug(省略可能)
Qhogo 　　→ Boolean形式で保護要素を設定するかどうかのFlug(省略可能)
Qkeisen 　　→ Boolean形式で罫線要素を設定するかどうかのFlug(省略可能)

※省略可能な引数は省略すると「True」となります。不必要な要素については、
Qkeisen:=False　←　罫線要素の設定をしない
とします。
セルに文字を入れる目的で使用する場合ですが、INI読込みのGetINIValue関数で末尾の空白を消されてしまいますので注意です。
----------------------------------------

(-。-)y-゜゜゜

=========以下、VBA!!（*^_^*）=============

Option Explicit

'API--------ini
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias _
        "GetPrivateProfileStringA" (ByVal lpApplicationName As String, _
                                    ByVal lpKeyName As Any, _
                                    ByVal lpDefault As String, _
                                    ByVal lpReturnedString As String, _
                                    ByVal nSize As Long, _
                                    ByVal lpFileName As String) As Long

Private Declare Function WritePrivateProfileString Lib "kernel32" Alias _
        "WritePrivateProfileStringA" (ByVal lpApplicationName As String, _
                                      ByVal lpKeyName As Any, _
                                      ByVal lpString As Any, _
                                      ByVal lpFileName As String) As Long

Public Function GetINIValue(Section As String, Key As String, _
                            ININame As String) As String
'-----ini読み込み関数----
    Dim Value As String * 255
    Call GetPrivateProfileString(Section, Key, "ERROR", Value, Len(Value), ININame)
    GetINIValue = Left$(Value, InStr(1, Value, vbNullChar) - 1)

End Function
Public Function SetINIValue(Section As String, Key As String, _
                            Value As String, ININame As String) As Boolean
'-----ini書き込み関数----
    Dim Ret As Long
    Ret = WritePrivateProfileString(Section, Key, Value, ININame)
    SetINIValue = CBool(Ret)

End Function


Sub SumpleA()
  Const Fname As String = "D:\try.ini"
  Call CellSettingINIWrit(ActiveSheet.Range("B2"), Fname)
End Sub

Sub SumpleB()
  Const ISE As String = "Sheet1-B2"
  Const Fname As String = "D:\try.ini"
  Call CellSettingINIRead(ISE, ActiveSheet.Range("D2"), Fname, _
                          Qshikiatai:=False, Qkeisen:=False)
End Sub


Public Sub CellSettingINIRead(ByVal IniSectionName As String, _
                              ByRef myRange As Range, _
                              ByVal iniFileName As String, _
                              Optional Qshikiatai As Boolean = True, _
                              Optional Qhyouji As Boolean = True, _
                              Optional Qhaichi As Boolean = True, _
                              Optional Qfont As Boolean = True, _
                              Optional Qnuri As Boolean = True, _
                              Optional Qhogo As Boolean = True, _
                              Optional Qkeisen As Boolean = True)
  
  Dim R         As Range
  Dim I         As Byte
  Dim iniSec    As String
  Dim Fname     As String
  Dim TX        As String
  Const FO      As String = "Font."     '-----keyの識別に使う文字
  Const IOR     As String = "Interior." '-----keyの識別に使う文字
    
    '----------引数のセット
    Set R = myRange.Cells
    Fname = iniFileName
    'Section名
    iniSec = IniSectionName
    
    'ini～Cell【数式・値】
    If Qshikiatai = False Then GoTo Point1
    R.FormulaLocal = CStr(GetINIValue(iniSec, "FormulaLocal", Fname))
    

Point1: '--------------------ini～Cell【セルの書式設定→表示形式】
    
'INI読込みの"GetINIValue"関数で末尾の空白を消されてしまうとErrorになる
    TX = CStr(GetINIValue(iniSec, "NumberFormatLocal", Fname))
      On Error Resume Next
    R.NumberFormatLocal = TX
      If Err.Number = 1004 Then R.NumberFormatLocal = TX + Chr(32)
        Err.Clear
    
Point2: '--------------------ini～Cell【セルの書式設定→配置要素】
    If Qhaichi = False Then GoTo Point3
    R.HorizontalAlignment = CInt(GetINIValue(iniSec, "HorizontalAlignment", Fname))
    R.VerticalAlignment = CInt(GetINIValue(iniSec, "VerticalAlignment", Fname))
    R.WrapText = CBool(GetINIValue(iniSec, "WrapText", Fname))
    R.Orientation = CInt(GetINIValue(iniSec, "Orientation", Fname))
    R.AddIndent = CBool(GetINIValue(iniSec, "AddIndent", Fname))
    R.IndentLevel = CInt(GetINIValue(iniSec, "IndentLevel", Fname))
    R.ShrinkToFit = CBool(GetINIValue(iniSec, "ShrinkToFit", Fname))
    R.ReadingOrder = CInt(GetINIValue(iniSec, "ReadingOrder", Fname))
    R.MergeCells = CBool(GetINIValue(iniSec, "MergeCells", Fname))

Point3: '--------------------ini～Cell【セルの書式設定→フォント要素】
  If Qfont = False Then GoTo Point4
  With R.Font
    .Name = CStr(GetINIValue(iniSec, FO & "Name", Fname))
    .FontStyle = CStr(GetINIValue(iniSec, FO & "FontStyle", Fname))
    .Size = CInt(GetINIValue(iniSec, FO & "Size", Fname))
    .Strikethrough = CBool(GetINIValue(iniSec, FO & "Strikethrough", Fname))
    .Superscript = CBool(GetINIValue(iniSec, FO & "Superscript", Fname))
    .OutlineFont = CBool(GetINIValue(iniSec, FO & "OutlineFont", Fname))
    .Shadow = CBool(GetINIValue(iniSec, FO & "Shadow", Fname))
    .Underline = CInt(GetINIValue(iniSec, FO & "Underline", Fname))
    .Color = CLng(GetINIValue(iniSec, FO & "Color", Fname))
    .TintAndShade = CInt(GetINIValue(iniSec, FO & "TintAndShade", Fname))
    .ThemeFont = CInt(GetINIValue(iniSec, FO & "ThemeFont", Fname))
  End With

Point4: '--------------------ini～Cell【セルの書式設定→塗りつぶし要素】
  If Qnuri = False Then GoTo Point5
  With R.Interior
    .Pattern = CInt(GetINIValue(iniSec, IOR & "Pattern", Fname))
    .PatternColorIndex = CInt(GetINIValue(iniSec, IOR & "PatternColorIndex", Fname))
    .Color = CLng(GetINIValue(iniSec, IOR & "Color", Fname))
    .TintAndShade = CInt(GetINIValue(iniSec, IOR & "TintAndShade", Fname))
    .PatternTintAndShade = CInt(GetINIValue(iniSec, IOR & "PatternTintAndShade", Fname))
  End With


Point5: '--------------------ini～Cell【セルの書式設定→保護要素】
    If Qhogo = False Then GoTo Point6
    R.Locked = CBool(GetINIValue(iniSec, "Locked", Fname))
    R.FormulaHidden = CBool(GetINIValue(iniSec, "FormulaHidden", Fname))


Point6: '--------------------ini～Cell【セルの書式設定→罫線】
  If Qkeisen = False Then GoTo Point7
  For I = 1 To 6 '-------------5to10でもok
    With R.Borders(I)
         '-----GetINIValue関数が"ERROR"を返す時は罫線が無い-----
      If GetINIValue(iniSec, I & "Borders.LineStyle", Fname) <> "ERROR" Then
        .LineStyle = CInt(GetINIValue(iniSec, I & "Borders.LineStyle", Fname))
        .ColorIndex = CInt(GetINIValue(iniSec, I & "Borders.ColorIndex", Fname))
        On Error Resume Next '--------↓罫線明るさの設定値だが、罫線が無い場合はError
        Err.Clear
        .TintAndShade = CInt(GetINIValue(iniSec, I & "Borders.TintAndShade", Fname))
        .Weight = CInt(GetINIValue(iniSec, I & "Borders.Weight", Fname))
      End If
    End With
  Next I

Point7: '--------------------処理終了（*^_^*）

  Set R = Nothing

End Sub



Public Sub CellSettingINIWrit(ByRef myRange As Range, _
                              ByVal iniFileName As String)
  
  Dim WS        As Excel.Worksheet
  Dim R         As Range
  Dim I         As Byte
  Dim iniSec    As String
  Dim Fname     As String
  Const FO      As String = "Font."     '-----keyの識別に使う文字
  Const IOR     As String = "Interior." '-----keyの識別に使う文字
    
    '----------引数のセット
    Set WS = myRange.Worksheet
    Set R = myRange.Cells
    Fname = iniFileName
    
    '----------同じ名称のini削除
    On Error Resume Next
    Err.Clear
    Kill Fname
    
    'Section名に使用する文字【Sheet名-Cellｱﾄﾞﾚｽ】
    iniSec = WS.Name & "-" & Replace(R.Address, "$", "")
    
    'ini→【数式・値】
    Call SetINIValue(iniSec, "FormulaLocal", R.FormulaLocal, Fname)
    
    'ini→【セルの書式設定→表示形式】
    Call SetINIValue(iniSec, "NumberFormatLocal", R.NumberFormatLocal, Fname)
    
    'ini→【セルの書式設定→配置要素】
    Call SetINIValue(iniSec, "HorizontalAlignment", R.HorizontalAlignment, Fname)
    Call SetINIValue(iniSec, "VerticalAlignment", R.VerticalAlignment, Fname)
    Call SetINIValue(iniSec, "WrapText", R.WrapText, Fname)
    Call SetINIValue(iniSec, "Orientation", R.Orientation, Fname)
    Call SetINIValue(iniSec, "AddIndent", R.AddIndent, Fname)
    Call SetINIValue(iniSec, "IndentLevel", R.IndentLevel, Fname)
    Call SetINIValue(iniSec, "ShrinkToFit", R.ShrinkToFit, Fname)
    Call SetINIValue(iniSec, "ReadingOrder", R.ReadingOrder, Fname)
    Call SetINIValue(iniSec, "MergeCells", R.MergeCells, Fname)
    
    'ini→【セルの書式設定→フォント要素】
  With R.Font
    Call SetINIValue(iniSec, FO & "Name", .Name, Fname)
    Call SetINIValue(iniSec, FO & "FontStyle", .FontStyle, Fname)
    Call SetINIValue(iniSec, FO & "Size", .Size, Fname)
    Call SetINIValue(iniSec, FO & "Strikethrough", .Strikethrough, Fname)
    Call SetINIValue(iniSec, FO & "Superscript", .Superscript, Fname)
    Call SetINIValue(iniSec, FO & "OutlineFont", .OutlineFont, Fname)
    Call SetINIValue(iniSec, FO & "Shadow", .Shadow, Fname)
    Call SetINIValue(iniSec, FO & "Underline", .Underline, Fname)
    Call SetINIValue(iniSec, FO & "Color", .Color, Fname)
    Call SetINIValue(iniSec, FO & "TintAndShade", .TintAndShade, Fname)
    Call SetINIValue(iniSec, FO & "ThemeFont", .ThemeFont, Fname)
  End With

    'ini→【セルの書式設定→塗りつぶし要素】
  With R.Interior
    Call SetINIValue(iniSec, IOR & "Pattern", .Pattern, Fname)
    Call SetINIValue(iniSec, IOR & "PatternColorIndex", .PatternColorIndex, Fname)
    Call SetINIValue(iniSec, IOR & "Color", .Color, Fname)
    Call SetINIValue(iniSec, IOR & "TintAndShade", .TintAndShade, Fname)
    Call SetINIValue(iniSec, IOR & "PatternTintAndShade", .PatternTintAndShade, Fname)
  End With

    'ini→【セルの書式設定→保護要素】
    Call SetINIValue(iniSec, "Locked", R.Locked, Fname)
    Call SetINIValue(iniSec, "FormulaHidden", R.FormulaHidden, Fname)

    'ini→【セルの書式設定→罫線】

  For I = 1 To 6 '-------------5to10でもok
    With R.Borders(I)
      If .LineStyle <> xlNone Then '------罫線の有無を判断
        Call SetINIValue(iniSec, I & "Borders.LineStyle", .LineStyle, Fname)
        Call SetINIValue(iniSec, I & "Borders.ColorIndex", .ColorIndex, Fname)
        On Error Resume Next '--------↓罫線明るさの設定値だが、罫線が無い場合はError
        Err.Clear
        Call SetINIValue(iniSec, I & "Borders.TintAndShade", .TintAndShade, Fname)
        Call SetINIValue(iniSec, I & "Borders.Weight", .Weight, Fname)
      End If
    End With
  Next I
'罫線のindex(11)と(12)は単一セルの処理なので無視
'xlInsideHorizontal----index(12)----セル範囲の内側の横線
'xlInsideVertical------index(11)----セル範囲の内側の縦線

    Set WS = Nothing
    Set R = Nothing

End Sub

行の並びをグチャグチャにする。【重複しない整数の乱数】

行の並びをグチャグチャにするVBAです(*^▽^*)

左が実行前で、右が実行後になります････････

まー、あんまり役に立たないVBAですね･･･････(-。-)y-゜゜゜

処理としては、

"重複しない整数の乱数"を生成する関数を作成しました【関数名:RandomNumber】

その関数を利用して、行のデータを入れ換える造りになってます。


Sub Sample()
  
  '配列を16384(全列数)展開してますので処理が遅いです。
  
  Dim LR    As Long
  Dim RR()  As Long
  Dim I     As Long
  Dim A     As Variant
  Dim B     As Variant
   
    Application.ScreenUpdating = False
    
    With ActiveSheet
      
      LR = .Cells(Rows.Count, 1).End(xlUp).Row
      RR = RandomNumber(1, LR)
      
        For I = 1 To LR
          A = .Rows(I)
          B = .Rows(RR(I - 1))
          .Rows(I) = B
          .Rows(RR(I - 1)) = A
        Next I
    
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "処理終了（*^_^*）"

End Sub



Public Function RandomNumber(SN As Long, LN As Long) As Long()
  
  Dim RN()      As Long
  Dim rndNo     As Long
  Dim A         As Long
  Dim B         As Long
  Dim I         As Long
  Dim R         As Long
    
    For I = 0 To LN - SN
      ReDim Preserve RN(I)
      RN(I) = I + SN
    Next I
      
    For R = LBound(RN) To UBound(RN)
      rndNo = Int(Rnd * UBound(RN)) + LBound(RN)    '乱数の発生
      A = RN(R): B = RN(rndNo)
      RN(R) = B: RN(rndNo) = A
      Next R
  
  RandomNumber = RN

End Function

行の処理例ですが、列とかSheetのグチャグチャも簡単に出来ますね（*^_^*）

前ページ
次ページ