エクセラのEXCEL
表計算ソフトEXCELでゲーム等を作っています。ゲーム等の作成状況を紹介。
スポンサーサイト
上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。
ユーザー定義関数でセルの内容を変更

関数でセルの内容を変更することはできませんが、以前、ユーザー定義関数(?)で強引にセルの内容を変更したことがあります。
次の例は、特定のセルの文字を回転させる関数(?)です。
なお再計算時には反映されません。

'標準モジュール
'使用例 =rotate(対象のセル範囲,回転角) 回転角は-90~90
Function rotate(a As Range, b As Long)
    rotate = a.Address & "," & b
End Function


'シートモジュール
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim a As Variant
    For Each ta In Target
        f = ta.Formula
        If f Like "*rotate(*,*)*" Then
            a = Split(ta, ",")  'a(0)は対象のセル a(1)は回転角
            Range(a(0)).Orientation = a(1)
        End If
    Next
End Sub

テーマ:EXCEL - ジャンル:コンピュータ

クイズ・ドレミファドン!
APIのBEEPを使うと、EXCELで音楽を流すことができます。
果たして何の曲が流れてくるでしょうか?
やり方のわからない人は、メール下さい。

Declare Function beep Lib "kernel32" Alias "Beep" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub sound()
Dim a()
a = [{32,5,0,2,24,2,32,2,40,2,48,2,40,2,0,2,32,2,36,2,0,2,36,2,36,2,0,2,27,5,0,1,36,2,32,2,0,2,30,2,32,5,0,2,24,2,32,2,40,2,48,2,40,2,0,2,32,2,34,2,0,2,34,2,34,2,0,2,32,5}]
For i = 1 To UBound(a) Step 2
If a(i) = 0 Then
Sleep a(i + 1) * 80
Else
beep a(i) * 10, a(i + 1) * 80
End If
Next
End Sub
はじめて自分のために

よく他の人のためにEXCELのマクロを作っていたが、今回たぶんはじめて自分のためにマクロを作った。
内容は、EXCELファイルが300個あり、その中の特定のデータを抜き取り、ひとつのファイルにするものだった。
300個をマクロを使わずに行うと、5時間は掛かったと思う。


Sub test()
 af = ActiveWorkbook.Name
 sr = Range("A65535").End(xlUp).Row + 1
 Set fs = Application.FileSearch
 FileToOpen = Application.GetOpenFilename("ファイル (*.xls),*.xls", , "目的のフォルダーを開いてください")
 If FileToOpen <> False Then
  Application.ScreenUpdating = False
  With fs
   .LookIn = Left(FileToOpen, InStrRev(FileToOpen, "\"))
   .SearchSubFolders = False: .Filename = "*.xls"
   If .Execute() > 0 Then
    For i = 1 To .FoundFiles.Count
     Workbooks.Open Filename:=.FoundFiles(i)
     With Workbooks(af).Worksheets(1)
途中省略
      Range(Cells(j, 1), Cells(j, 25)).Copy (.Cells(sr, 1))
途中省略
    Windows(Mid(.FoundFiles(i), InStrRev(.FoundFiles(i), "\") + 1)).Close
     End With     
    Next
   End If
  End With    
 End If
End Sub


たったこれだけで、5時間が2分以下に。はじめてVBAを覚えてよかったと思った。


そうそう、ブログの更新だけでなく、ゲーム作りも忘れていた。

無駄なことをやっていた(その2)

グラフ編
以前、データの無いところを補完して線を結ぶ方法を知らなかったとき
Function y(x1, y1, x2, y2, x)
    y = (y1 - y2) / (x1 - x2) * (x - x1) + y1
End Function
と中学生のとき?に習った2点間を通る直線の式を関数にしていた。
その後、わざわざ関数を作らなくてもForecastで計算できることを知った。
FORECAST(x, 既知のy, 既知のx)


さらにその後、わざわざ関数を使わなくても、データを補完して線を引いてくれる
機能があることを知った。
ツール-オプション-グラフ-補完してプロットする

テーマ:EXCEL - ジャンル:コンピュータ

文字(式)の計算
セルに計算式を文字として入力してあり(例えば 1+1)、
この部分を計算したい場合があった。
どのようにして計算すればよいのか調べて見ると
Evaluateを使えば計算できることが分かった。
Function calc(a)
    calc = Evaluate(a)
End Function
どこかのセルで =calc(計算したいセル)で計算可能。
最近、エクセルで出来ないものはないような気がしてきた。

テーマ:プログラミング - ジャンル:コンピュータ

がんばれ日本
子供達が寝て、VBAゲームプログラミングのチャンスと、22時からPCに向かう。しかし、サッカークロアチア戦が気になって、キーボードに手が行かなかった。前半戦終了でこれから後半戦。今日はPCはやめておこう。

テーマ:日記 - ジャンル:日記

今日も人のためにVBAを

1つのデータが2行に渡って入力されており、それが200件を超えており、2行を1行にまとめる次のようなマクロを作ってあげた。
Sub test()
    Dim i As Long, j As Long
    Application.ScreenUpdating = False
    Rows("7:7").Select
    Selection.AutoFilter
    Selection.AutoFilter Field:=1, Criteria1:="計"
    Rows("10:2000").Select
    Selection.Delete Shift:=xlUp
    Selection.AutoFilter
    For i = Range("C65535").End(xlUp).Row To 9 Step -2
        For j = 1 To 16
            Cells(i, j) = Cells(i - 1, j) & Cells(i, j)
        Next
        Range(i - 1 & ":" & i - 1).Delete
    Next
    Application.ScreenUpdating = True
    Range("A8").Select
End Sub
オートフィルターで、不必要な行(ここでは”計”となっている行)を削除し、2行を1行にして、不要な1行を削除。
当然、Application.ScreenUpdatingをFalseにして、作業速度アップ。たいしたマクロではないが、普段マクロを使うことのない人にとっては驚きのようだ。
またこの間、とある会社から、お金を払うからVBAを作ってくれないかと、メールで依頼があったが、簡単だったので、ただで作ってあげたらこれまた非常に喜んでくれた。
そんなにすごいことをした訳ではないが、チョッピリうれしかった。

テーマ:プログラミング - ジャンル:コンピュータ

無駄なことをやっていた

標準で装備されている関数を何度か作ったことがある。
これ以外でも、まだ気が付かずに無駄なことをたくさんやっているんだろうな~


1.文字の色
 VBAの場合
  Function color(a As Range) As Long
    color = a.Font.ColorIndex
  End Function


 VBAを使わない方法
  挿入-名前-定義
  名前:色
  参照範囲:=GET.CELL(24,A1)


2.ファイル名の表示
 VBAの場合
  Function filename()
     filename = ActiveWorkbook.Name
  End Function


 VBAを使わない場合1
  =REPLACE(LEFT(CELL("filename"),FIND("]",CELL("filename"))-1),1,FIND("[",CELL("filename")),)


 VBAを使わない場合2
  名前定義
  名前:ファイル名
  参照範囲:=GET.DOCUMENT(88)



3.Find関数があるのにわざわざinstr関数を作ってしまった
 VBAの場合
  Function instr(a As Range, b As String)
     instr = InStr(a.Value, b)
   End Function
 
 VBAを使わない場合  
  FIND関数


4.replace関数があるのにわざわざ同じものをつくってしまった
 無駄な例
  Function replace(a As String, b As String, c As String)
     Dim e As Variant
     e = Split(a, b)
     replace = Join(e, c)
  End Function


 Sub test()
    MsgBox replace("abcdefg", "cde", "")
 End Sub


 実はこれでだけでいい
  Sub test2()
   MsgBox Replace("abcdefg", "cde", "zzz")
  End Sub


 

テーマ:プログラミング - ジャンル:コンピュータ

画像データの貼り付け時にJPEG化

画像編集ソフト(PAINTSHOP、PHOTOSHOP,PHOTO EDITOR)で、画像をコピーし、
EXCELに貼り付けることがよくある。
元のファイルがJPEGであってもこの方法だとビットマップになり、膨大な
EXCELファイルになってしまう。
貼り付けるときに次のマクロを使うことで、自動的にJPGにしてくれるので、
愛用しています。


Sub bmp2jpg()
    ActiveSheet.Paste
    With Selection
        .ShapeRange.Line.Visible = msoFalse
        .Copy
        .Delete
    End With
    ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False,DisplayAsIcon:=False
End Sub


やっていることは、
ビットマップで貼り付け後、コピー、形式を選択して貼り付け 図 (JPEG)で
貼り付ける形式を"図 (JPEG)"にしているだけ。
エラーチェックをしていないので、時々エラーが出ることがあります。

テーマ:プログラミング - ジャンル:コンピュータ

データの重複入力を避ける

データ入力時に重複を避けたいので、次のようにした
Private Sub Worksheet_Change(ByVal Target As Range)
    With Target
        For i = 1 To .Row
            If .Value <> "" Then
                If .Value = Cells(i, .Column) Then
                    MsgBox "重複しています"
                    .Select
                    Exit For
                End If
            End If
        Next
    End With
End Sub


入力規則でできるのでは?と言われたので、やってみた。
例)B列の設定
入力規則で
ユーザー設定 =COUNTIF(B:B,B1)=1
ついでに条件付書式で
数式 =COUNTIF(B:B,B1)>1
 書式-パターン-赤
VBAよりシンプルだ。でもVBAで処理する方が素敵だと、いつも自分に言い聞かす

テーマ:プログラミング - ジャンル:コンピュータ

copyright © 2005 エクセラのEXCEL all rights reserved.
Powered by FC2ブログ.
上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。