Sub Macro1()
Dim linname As Variant

linname = ActiveWorkbook.LinkSources(xlLinkTypeExcelLinks)
  If IsEmpty(linname) Then
      MsgBox "ExcelLinkは設定されていません"
  Else
      MsgBox linname(1)
  End If
End Sub

Sub Macro2()
ActiveWindow.WindowState = xlNormal
For Each sheet_name In Worksheets
    snam = sheet_name.Name
    Sheets(snam).Copy
  linname = ActiveWorkbook.LinkSources(xlLinkTypeExcelLinks)
  If IsEmpty(linname) Then
     ActiveWorkbook.Saved = True
     ActiveWorkbook.Close
  Else
  linn = Right(linname(1), 6)
  ActiveSheet.UsedRange.Select
  Set actv = Selection.Find(linn, , , xlPart, xlByColumns)
        If actv Is Nothing Then
            Else
              actv.Select
              r = ActiveCell.Row
              c = ActiveCell.Column
            End If
 
      MsgBox "このシ−トにリンクがあります" & Chr$(10) & _
      "シ−ト名は　" & snam & Chr$(10) & _
      "リンク元は　" & linname(1) & Chr$(10) & _
      "リンクの記述セル（" & r & "行、" & c & "列）"
    ActiveWindow.WindowState = xlMinimized
  End If
Next
End Sub

Sub ki37()
　 fil2  = "C:\tst\" & fff & ".xls"  'フォルダ−名を変更し使用の事
   fil2a = fff & ".xls"

    fila = 0
     For Each file_name In Windows
        If file_name.Caption = fil2a Then
             Windows(fil2a).Activate
            fila = 1
        End If
    Next
        If fila = 0 Then
           Workbooks.Open Filename:=fil2
        End If
End Sub

Sub fck1()
fff = Application.GetOpenFilename(Title:="ファイル名指定")
dat = GetAttr(fff)
    If dat = 1 Then
        MsgBox fff & "は読取専用ファイルです"
    Else
        MsgBox fff & "は読取専用ファイルでは有りません"
    End If
End Sub
'--------------------------------------------------------------------------
Sub fck2()
  Application.ScreenUpdating = False
  For Each file_name In Windows
     Windows(file_name.Caption).Activate
     dat = GetAttr(ActiveWorkbook.FullName)
    If dat = 1 Then
        MsgBox ActiveWorkbook.FullName & "は読取専用ファイルです"
    Else
      MsgBox ActiveWorkbook.FullName & "は読取専用ファイルでは有りません"
    End If
 Next
End Sub

Sub bbb1()
    SetAttr "c:\My Documents\Book3.xls", vbReadOnly
End Sub
Sub bbb2()
    SetAttr "c:\My Documents\Book3.xls", vbNormal
End Sub

Sub fck3()
fff = Application.GetOpenFilename(Title:="ファイル名指定")
erck = 0
On Error GoTo errcheck
Open fff For Binary Lock Read Write As #1
Close #1

If erck = 1 Then
   MsgBox fff & " は使用中です" & Chr(13) & _
           "後で再度起動してください。"
Else
    Workbooks.Open Filename:=fff
End If

Exit Sub
'
errcheck:
    erck = 1
    Resume Next
End Sub

Sub Macro1()
	Workbooks.OpenText Filename:=fil2, StartRow:=1, _
        DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
        Comma:=True, Space:=False, Other:=False, _
        FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), _
        Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1))
End Sub

Sub Macro1()
   Workbooks.OpenText Filename:=fil2, DataType:=xlDelimited, Comma:=True 
End Sub

Sub Macro1()
   fil2 = "C:\My Documents\Book2.txt"
   Workbooks.OpenText Filename:=fil2, DataType:=xlFixedWidth, _
    FieldInfo:=Array(Array(0, 2), Array(5, 2), Array(10, 1), _
        Array(15, 1), Array(20, 1), Array(25, 1))
End Sub

'カンマ区切りCSVファイルで保存
Sub Record1()
    ActiveWorkbook.SaveAs Filename:="C:\My Documents\Book1.csv", _
        FileFormat:=xlCSV, CreateBackup:=False
End Sub
'
'タブ区切りテキストで保存
Sub Record2()
    ActiveWorkbook.SaveAs Filename:="C:\My Documents\Book1.txt", _
        FileFormat:=xlText, CreateBackup:=False
End Sub
'
'スペ−ス区切りPRNファイルで保存
Sub Record3()
    ActiveWorkbook.SaveAs Filename:="C:\My Documents\Book1.prn", _
        FileFormat:=xlTextPrinter, CreateBackup:=False
End Sub

Sub Record1()
'txtデ−タ取り込み
    i = 1: j = 0: keis = 3: toki = 1: shoki = 0
    Open fff For Input As #1
   j = 14
Do Until EOF(1)
    Input #1, dat
'出品no
   If j > 12 Then
        keis = 1
        toki = 0
        j = 1
   End If
'AC空白
    If j = 4 Then
        data = Left(dat, 1)
        If data > Chr$(&H40) And data < Chr$(&H7B) Then
                keis = 3
        Else
                Cells(i, 5) = ""
                j = j + 1
                 keis = 3
        End If
    End If
'特記事項
 If toki = 0 Then
    If j > 7 Then
          s1 = InStr(1, dat, "/", 1)
      If s1 > 0 Then
          s2 = Mid(dat, s1 + 1, 2)
         If Val(s2) <> 0 Then
            keis = 3          '特記事項終了
            toki = 1
         End If
      End If
         If toki = 0 Then
            keis = 2
         Else
            If kesi <> 1 Then
                keis = 3
            End If
         End If
    End If
End If
'セルへ書き込み
    Select Case keis
        Case 1
             j = 1
             i = i + 1
             Cells(i, j) = dat
             keis = 3
        Case 2
             Cells(i, j) = Cells(i, j) & dat
        Case 3
            j = j + 1
            Cells(i, j) = dat
    End Select
Loop
Close #1
End Sub

Sub Record1()
 Dim dat(13) As String      
'txtデ−タ取り込み
    i = 1: j = 1
    Open fff For Input As #1
Do Until EOF(1)
    Input #1, dat(1), dat(2), dat(3), dat(4), dat(5), dat(6), _
     dat(7), dat(8), dat(9), dat(10), dat(11), dat(12), dat(13)
'セルへ書き込み
    For j = 1 To 13
        Cells(i, j) = dat(j)
    Next
    i = i + 1
Loop
Close #1
End Sub

[1999/12/21 H.Tさんからの質問]
「Excel　VBAマクロ　５００連発」　（技術評論社） 書店で拝見し、衝動買いしてしまいました。 すばらしいです。 ソースをコピーして使えるのは楽です。 しかし、私はマクロは今月興味を持ち始めたばかりなので、使える物は全く作れません。

今度の同級会(H12/1/3)で幹事長を任されまして、ビンゴゲームを盛り上げるために、ＰＣをルーレットに 使ってプロジェクタ（手配済み）で大写してに数字を表示したいと考えたのが切っ掛けなのです。 市販アプリケーションと家庭用ゲームソフトを手分けして探していますが、見つ かりません。

ほしい機能は
�@普通のランダムによる数字表示
�Aあらかじめ仕込んでいた順番の通りに数字が出る。（予め当たるカードを仕込める）
�Bビンゴカード一式をカラー印刷出来る。（無くても良い）

---

依頼の件、 2000サンプル[10]KIbingoへ掲載したので使用して 下さい。



上記の�@については乱数を使用したランダム表示を２種類作りました(抽選後拡大表示)。 その他アミダくじも作成したので、自分のカ−ドにあり欲しい数字をセルへ記入して頂き 抽選する方法も可能です（勿論横線は自由に追加できる）。
�Aについてはランダム抽選２種類のうち一つでは仕込んでおいた数字が出るようにしました。
�BについてはA4用紙に４カ−ド印刷できます。その他改善点はメ−ルを頂けば暇があれば対応します。

---

【戻る】