SSブログ
Excel2000 VBA独習 ブログトップ
前の16件 | 次の16件

EXCEL2000 VBA 上に移動 [Excel2000 VBA独習]

EXCEL2000 VBA  上に移動

Sub 入れ替えswap()
'選択セルと1つ上のセルの値を入れ替える(上に移動)
    Dim sRsC As Long
    Dim D1D2 As Variant
 
        On Error GoTo owari '1行目を選択したときのエラー対策
 
'選択セルの行列を調べる
    sR = Selection.Row
    sC = Selection.Column
'値を変数に代入
    D1 = Cells(sRsC)
    D2 = Cells(sR - 1, sC)  '1つ上のセル
'セルに書き込み
    Cells(sRsC) = D2
    Cells(sR - 1, sC) = D1
'セル選択
    Cells(sR - 1, sC).Select
'1行目を選択してエラーが出たらこのラベルに飛んで来る
owari:
     Exit Sub
 
End Sub

 

 


追記 複数列に対応

 

Sub 選択範囲を上に移動()
 
'選択範囲(1行)を上に移動(値のみ)
 
    Dim sRsCsCcontsRcont As Long
    Dim D1(), D2()
    Dim i As Long
 
         On Error GoTo owari '1行目を選択したときのエラー対策
 
'選択範囲を調べる
    sR = Selection.Row
    sC = Selection.Column
    sCcont = Selection.Columns.Count
    sRcont = Selection.Rows.Count
 
'選択範囲の行が1列以上なら、メッセージを表示して終了
    If sRcont > 1 Then MsgBox "選択行範囲は1行にしてください": Exit Sub
 
'選択範囲の値をD1()配列に格納
    ReDim D1(sCcont), D2(sCcont)
 
     For i = 1 To sCcont
        D1(i) = Cells(sRsC + i - 1).Value
       ' Debug.Print D1(i)
     Next i
 
'1つ上の範囲の値をD2()に格納
    For i = 1 To sCcont
        D2(i) = Cells(sR - 1, sC + i - 1).Value
        'Debug.Print D2(i)
    Next i
 
'選択範囲に1つ上のセルの値を代入
    For i = 1 To sCcont
        Cells(sRsC + i - 1) = D2(i)
        Cells(sR - 1, sC + i - 1) = D1(i)
    Next i
'選択範囲を移動
    Range(Cells(sR - 1, sC), Cells(sR - 1, sC + sCcont - 1)).Select
 
'1行目を選択してエラーが出たらこのラベルに飛んで来る
owari:
     Exit Sub
 
End Sub

 

 


タグ:Excel2000 VBA

EXCEL2000 VBA 選択範囲(1列)の重複を取り除いて右側に表示する。 実験 [Excel2000 VBA独習]

EXCEL2000 VBA  選択範囲(1列)の重複を取り除いて右側に表示する。 実験

ExcelVBA_jyuufuku_01.png

Sub選択範囲列の重複データを取り除いたデータを作る()
'選択範囲の重複データを取り除いたデータを作る
'
Dim ij As Long       '汎用
Dim d() As Variant    'セル値格納用配列
Dim k As Long        '重複の無いデータ個数
Dim x As Variant     '
Dim FL1 As Integer  '重複が有れば FL=1 無ければ FL=0
Dim sRow As Long    '選択範囲の先頭列番号
Dim sCol As Long        '選択範囲の列番号
 
ReDim d(Selection.Rows.Count + 1)
If Selection.Columns.Count > 1 Then MsgBox "列幅は1つにしてください": Exit Sub
sRow = Selection.Row
sCol = Selection.Column
d(1) = Selection.Rows(1)
k = 1
For i = 1 To Selection.Rows.Count
    x = Selection.Rows(i).Value
    FL1 = 0
    '重複があるか判定
        For j = 1 To k
            If d(j) = x Then FL1 = 1     'd()の値と同じもが有ればFL=1
        Next j
        If FL1 <> 1 Then d(k + 1) = xk = k + 1  '重複が無ければ値をd(+1)に代入
             'Debug.Print k, d(k)
        Next i
    'd()一覧を表示
        For i = 1 To k
            Cells(sRow + i - 1, sCol + 1) = d(i)
        Next i
 
End Sub
 

 

 


追記 
 一応 使えるかも?バージョン

 

Sub 選択範囲列の重複データを取り除いたデータを作る()
'選択範囲の重複データを取り除いたデータを作る
'
    Dim ij As Long       '汎用
    Dim d() As Variant    'セル値格納用配列
    Dim k As Long        '重複の無いデータ個数
    Dim x As Variant     '
    Dim FL1 As Integer  '重複が有れば FL=1 無ければ FL=0
    Dim sRow As Long    '選択範囲の先頭列番号
    Dim sCol As Long        '選択範囲の列番号
    Dim input_range As Range    'InputBox で入力されたRange
 
    On Error GoTo Er
 
'配列の個数設定
    ReDim d(Selection.Rows.Count + 1)
'選択列数 確認
    If Selection.Columns.Count > 1 Then MsgBox "列幅は1つにしてください": Exit Sub
'初期設定
    sRow = Selection.Row    '選択セルの先頭行番号
    sCol = Selection.Column '選択セルの列番号
    d(1) = Selection.Rows(1)    '先頭セルの値を配列(1)に代入
    k = 1                           '重複しないデータの個数初期値
'行数分だけ処理
    For i = 1 To Selection.Rows.Count
        x = Selection.Rows(i).Value
        FL1 = 0
         '重複があるか判定
            For j = 1 To k
                If d(j) = x Then FL1 = 1     'd()の値と同じもが有ればFL=1
            Next j
                If FL1 <> 1 Then d(k + 1) = xk = k + 1  '重複が無ければ値をd(+1)に代入
             'Debug.Print k, d(k)
    Next i
    'd()一覧を表示するセルを決める
        'inputobox で入力
inB:    'ラベル
    'Inputboxでセル選択
            Set input_range = Application.InputBox("表示する先頭セルを1つ選択してください。", _
            "表示セルの選択", , , , , , 8)
 
    'd()一覧を表示
        For i = 1 To k
            input_range.Offset(i - 1, 0) = d(i)
        Next i
    '終了
    Exit Sub
Er:  'エラー処理
    'キャンセルボタンが押されたら のつもり
        If Err.Number = 424 Then Exit Sub
    '選択セルが1つ以上
        If Err.Number = 13 Then MsgBox "選択セルは1つにしてください": GoTo inB
    'その他のエラー
    MsgBox "error " & Err.Number
 
End Sub

 

 

 


EXCEL2000 VBA 最終行を調べる関数を作った。 [Excel2000 VBA独習]

EXCEL2000 VBA  最終行を調べる関数を作った。

Excelの関数で、空白の有る列の最終入力の有る行番号を調べる関数がない?ので作ってみた。

Excelでは
=OFFSET(B1,COUNTA(B:B)-1,0)
=INDEX($B:$B,COUNTA($B:$B),1)
=MAX(INDEX((LEN(A1:A65534)>0)*ROW(A1:A65534),0)) 空白が有ってもOK

な感じで最終行を調べる(空白が有ると上手くいかない)

 

作った関数
Function last_rowN(col As Variant)
'最終行番号を返す
    last_rowN = Cells(65536, col).End(xlUp).Row
End Function

 

作り方
ブックを新規作成
VBEを起動して上記のコードを記入
ファイル名を****.xla で保存
Excelのメニューバー→ツール→アドイン で、ダイアログの参照ボタンを押し先ほど保存したxlaファイを選択しアドインにする

Excel なら A列の最終行番号を調べるには、=last_rowN("A")、=last_rowN(1)とセルに記入
VBA なら a=last_rowN(selection.column)

本当は、=SUM(A1:"A" & last_rowN("A")) のように利用したかったが、エラーが出てダメだった、残念

追記

関数名をlast_rowN から last_row に変更

="A" & TEXT(last_row("A"),0) はOK
=sum("A1":("A" & TEXT(last_row("A"),0))) はNG

A2から入力のある最終行まで選択(可変範囲指定で、エクセルの関数を駆使して作るより簡単!

=OFFSET(List!$A$2,0,0,last_row("A"),1)

追記型名前範囲に使うと便利

Excel_userkansuu_name_01.png
Excel_userkansuu_name_02.png

=SUM(OFFSET(A1,0,0,last_row(1),1)) こんな使い方もできる。

Excel_userkansuu_sum_02.png

 

 

 

 

 

 

 

 


タグ:Excel2000 VBA

EXCEL2000 VBA XLSTARTフォルダとExcel.libを世代間バックアップする実験 [Excel2000 VBA独習]

EXCEL2000 VBA  XLSTARTフォルダとExcel.libを世代間バックアップする実験

VBA_backup.png

Sub xlStartフォルダをバックアップ()
'
'xlStartフォルダFULLパス
'C:\Documents and Settings\nokie\Application Data\Microsoft\Excel
'Excelフォルダを世代間バックアップ(XLSTARTフォルダ+Excel.lib)
'
 
Dim ExcelDir As String      'Excelフォルダパス
Dim SaveDir As String       '保存先フォルダパス
Dim FSO As Object           'FileSystemObject
Dim newDirname As String    '新しい保存フォルダ
 
 
    'ExcelフォルダFULLパス
        ExcelDir = "C:\Documents and Settings\nokie\Application Data\Microsoft\Excel"
    '保存先フォルダパス
        newDirname = Left(Now, 10)   '2012/10/26 17:56:01 → 2012/10/26
        ' / を消す
        newDirname = Replace(newDirname, "/", "")    '/をnullに
        SaveDir = "D:\nokie_BK\office\Excel\" & newDirname  '年月日フォルダ
    'Excelフォルダをコピー
        Set FSO = CreateObject("Scripting.FileSystemObject")
                FSO.CopyFolder ExcelDirSaveDir
        Set FSO = Nothing
 
End Sub
 

ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

一応完成

 

Sub xlStartフォルダをバックアップ()
'
'xlStartフォルダFULLパス
'C:\Documents and Settings\nokie\Application Data\Microsoft\Excel
'Excelフォルダを世代間バックアップ(XLSTARTフォルダ+Excel.lib)
'
 
Dim ExcelDir As String      'Excelフォルダパス
Dim SaveDir As String       '保存先フォルダパス
Dim FSO As Object           'FileSystemObject
Dim newDirname As String    '新しい保存フォルダ
 
 
    'ExcelフォルダFULLパス
        ExcelDir = "C:\Documents and Settings\nokie\Application Data\Microsoft\Excel"
    '保存先フォルダパス
        newDirname = Left(Now, 10)   '2012/10/26 17:56:01 → 2012/10/26
        ' / を消す
        newDirname = Replace(newDirname, "/", "")    '/をnullに
        SaveDir = "D:\nokie_BK\office\Excel\" & newDirname  '年月日フォルダ
    'Excelフォルダをコピー
        Set FSO = CreateObject("Scripting.FileSystemObject")
                FSO.CopyFolder ExcelDirSaveDir
        Set FSO = Nothing
    'メッセージ
        MsgBox "完了しました"
    '保存フォルダを開く
        Call Shell("""C:\WINDOWS\EXPLORER.EXE"" ""D:\nokie_BK\office\Excel""")
End Sub

 


タグ:Excel2000 VBA

EXCEL2000 VBA ハイパーリンク一覧を作成する 実験 [Excel2000 VBA独習]

EXCEL2000 VBA  ハイパーリンク一覧を作成する 実験

EXCEL2000VBA_HL01.png

EXCEL2000VBA_HL02.png

 

Sub シートのハイパーリンク一覧()
'
Dim newS As Worksheet           '
Dim aSname As String              '選択しているシート名
Dim newSname As String          '新しく作るシート名
Dim i As Long                       '汎用
Dim msg As Variant                'vbyesyno の値
 
 '一覧を作成するシートをすぐ後に作る(シート名は選択シート+”HL一覧”)
    aSname = ActiveSheet.Name      'シート名
    'シート名の確認
        msg = MsgBox("アクティブシート名は " & aSname & "です。" & vbCrLf & vbCrLf & "このシートのハイパーリンク一覧を作成しますか?", vbYesNo)
            Select Case msg
                Case vbYes
                    GoTo yes
                Case vbNo
                    MsgBox "処理を終了します。シートを選択し直してから実行してください"
                    Exit Sub
            End Select
yes:
 '同一のシート名があるか調べる(同一のシート名があったらシートセル全体の値を消す)
        For i = 1 To ActiveWorkbook.Sheets.Count
            If ActiveWorkbook.Sheets(i).Name = aSname & "HL一覧" Then ActiveWorkbook.Sheets(i).Cells.Delete: GoTo make
        Next i
    '新しくシートを作成
        Worksheets.Add(After:=Worksheets(ActiveSheet.Name)).Name = aSname & "HL一覧"
    '
   
'シートのハイパーリンク一覧を作成
make:
    newSname = Worksheets(aSname).Name & "HL一覧"
        For i = 1 To Worksheets(aSname).Cells.Hyperlinks.Count
            Worksheets(newSname).Cells(i, 1) = Worksheets(aSname).Hyperlinks(i).Range.Address  'アドレス $A$1
            Worksheets(newSname).Cells(i, 2) = Range(Worksheets(aSname).Hyperlinks(i).Range.Address).Value 'セルの値
            Worksheets(newSname).Cells(i, 3) = Worksheets(aSname).Hyperlinks(i).Address     'ハイパーリンクの値
    Next i
'作成したハイパーリンク一覧をセレクトしセル幅を整える
        Worksheets(newSname).Cells.EntireColumn.AutoFit

End Sub

 Worksheets("Excel関数").Hyperlinks.Delete    はできる

Worksheets("Excel関数").Hyperlinks=False      はできない ?

EXCEL2000VBA_HL03.png

 


EXCEL2000 VBA ハイパーリンクの有るセルを選択出来ないようする 実験(失敗)その2 [Excel2000 VBA独習]

EXCEL2000 VBA ハイパーリンクの有るセルを選択出来ないようする 実験(失敗)その2

http://telstar.blog.so-net.ne.jp/2012-10-17-1  のつづき

ハイパーリンクの設定文字列に [']を一文字目に付加し選択するとエラーダイアログを表示する(表示したくはないが)。
ハイパーリンクが不適切なので開く事は無い。
もう一度マクロを実行すると有効にできる。

excel_select_3.png

 

Sub ハイパーリンクを有効無効()
'ハイパーリンクが設定されてるセルの値に「’」シングルクオーテーションを付加して
'無効にする。(エラーにする)警告ダイアログがでる
'有効にするには、「’」シングルクオーテーションを削除する

'
Dim HLcount As Long                                 'ハイパーリンクの個数
Dim Raddress As String     'ハイパーリンクのあるセルアドレス
Dim HL_address As String              'ハイパーリンク内容
Dim i As Long                                              'カウンター用


'選択シートに設定されているハイパーリンクの個数を調べる
    HLcount = ActiveSheet.Cells.Hyperlinks.Count
'ハイパーリンクが無ければ終了、
    If HLcount = 0 Then Exit Sub
'ハイパーリンクの文字列の最初の文字が[']か調べる

    If Left((ActiveSheet.Hyperlinks(1).Address), 1) = "'" Then GoTo 有効 Else GoTo 無効
無効:
'ハイパーリンクの値に「 ' 」を文字列の先頭つける
    For i = 1 To HLcount
        Raddress = ActiveSheet.Hyperlinks(i).Range.Address
        HL_address = "'" & ActiveSheet.Hyperlinks(i).Address
        ' [']を付加した文字列をハイパーリンクに設定
        ActiveSheet.Hyperlinks.Add Anchor:=Range(Raddress), Address:=HL_address
    Next i
    Exit Sub
有効:
'ハイパーリンクを調べる
    For i = 1 To HLcount
        Raddress = ActiveSheet.Hyperlinks(i).Range.Address
        ' 付加した[']を削除
        HL_address = Right(ActiveSheet.Hyperlinks(i).Address, Len(ActiveSheet.Hyperlinks(i).Address) - 1)
        ActiveSheet.Hyperlinks.Add Anchor:=Range(Raddress), Address:=HL_address
    Next i

End Sub

感想

まぁいいか~ ← 子供みたいだねぇ (小倉さん風)

追記

Sub ハイパーリンクを有効無効()
'ハイパーリンクが設定されてるセルの値に「’」シングルクオーテーションを付加して
'無効にする。(エラーにする)警告ダイアログがでる
'有効にするには、「’」シングルクオーテーションを削除する
'
Dim HLcount As Long          'ハイパーリンクの個数
Dim Raddress As String       'ハイパーリンクのあるセルアドレス
Dim HL_address As String   'ハイパーリンク内容
Dim i As Long                      'カウンター用
Dim mymesse As String       'メッセージ文字列

'選択シートに設定されているハイパーリンクの個数を調べる
    HLcount = ActiveSheet.Cells.Hyperlinks.Count
'ハイパーリンクが無ければ終了、
    If HLcount = 0 Then Exit Sub
'ハイパーリンクの文字列の最初の文字が[']か調べる
    If Left((ActiveSheet.Hyperlinks(1).Address), 1) = "'" Then GoTo 有効 Else GoTo 無効
   
無効:
'ハイパーリンクの値に「 ' 」を文字列の先頭つける
    For i = 1 To HLcount
        Raddress = ActiveSheet.Hyperlinks(i).Range.Address
        HL_address = "'" & ActiveSheet.Hyperlinks(i).Address
        ' [']を付加した文字列をハイパーリンクに設定
        ActiveSheet.Hyperlinks.Add Anchor:=Range(Raddress), Address:=HL_address
    Next i
        mymesse = "ハイパーリンクを不正にしました"
        MsgBox mymesse
    'ステータスバーに状態表示
        Application.StatusBar = mymesse
    Exit Sub
有効:
'ハイパーリンクを調べる
    For i = 1 To HLcount
        Raddress = ActiveSheet.Hyperlinks(i).Range.Address
        ' 付加した[']を削除
        HL_address = Right(ActiveSheet.Hyperlinks(i).Address, Len(ActiveSheet.Hyperlinks(i).Address) - 1)
        ActiveSheet.Hyperlinks.Add Anchor:=Range(Raddress), Address:=HL_address
    Next i
        mymesse = "ハイパーリンクを戻しました"
        MsgBox mymesse
        MsgBox mymesse
    'ステータスバーに状態表示
        Application.StatusBar = mymesse

End Sub

 

 


EXCEL2000 VBA シートを隠す 実験 [Excel2000 VBA独習]

EXCEL2000 VBA  シートを隠す 実験

EXCEL2000VBA_sheet_04.png

メニューバーの 書式→シート→再表示 可能

EXCEL2000VBA_sheet_01.png

EXCEL2000VBA_sheet_02.png

 Sub シート非表示()
Worksheets("Sheet1").Visible = False
End Sub

Sub シートを隠す再表示可()
     ' シートを隠す(ツールバーの再表示可)
     Worksheets("sheet1").Visible = xlHidden      ' ←非表示

End Sub

メニューバーの 書式→シート→再表示 不可

EXCEL2000VBA_sheet_03.png

 

Sub シートを隠し再表示させない()
     ' シートを隠す(ツールバーの再表示に表示させない)
     '
     Worksheets("sheet1").Visible = xlVeryHidden

End Sub

ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

表示する

Sub シート表示()
Worksheets("sheet1").Visible = True
End Sub

Sub 隠したシートを再表示()
     ' 隠したシートを再表示
    Worksheets("sheet1").Visible = xlSheetVisible
    Worksheets("Sheet1").Select
   
End Sub

参照サイト ttp://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_020.html

-------------------------------------------------------------------------------------

追記 隠しシート一覧をメッセージボックスに表示、(出来が悪い)

Sub 隠しシート一覧()
Dim i As Long                       '汎用カウンタ
Dim d() As String                   'シート名配列
Dim sheetC As Long              'bookのシート数
Dim msgS As String              'msgbox用文字列
'bookのシート数を調べる
    sheetC = ActiveWorkbook.Sheets.Count
'配列d 個数設定
    ReDim d(sheetC)
'シートが非表示常態か調べる
    For i = 1 To sheetC
        If ActiveWorkbook.Sheets(i).Visible = False Or ActiveWorkbook.Sheets(i).Visible = xlVeryHidden Then d(i) = Sheets(i).Name
    Next i
        For i = 1 To sheetC
            msgS = msgS & d(i) & vbCrLf
        Next i
    MsgBox msgS

End Sub

▼非表示シートを確認しながら再表示するマクロ ttp://www.relief.jp/itnote/archives/001295.php

Sub シートを再表示する()

 Dim s As Object
 Dim ret As Long
 
 For Each s In ActiveWorkbook.Sheets
  With s
   If .Visible = False Then
    ret = MsgBox( _
     "シート『" & .Name & "』を再表示しますか?", _
     vbYesNo)
    If ret = vbYes Then .Visible = True
   End If
  End With
 Next s

End Sub

 

 


タグ:Excel2000 VBA

EXCEL2000 VBA ハイパーリンクの有るセルを選択出来ないようする 実験(失敗) [Excel2000 VBA独習]

EXCEL2000 VBA  ハイパーリンクの有るセルを選択出来ないようする 実験

EXCEL2000VBA_kansu_01.png

上の画像のように、関数HELPを作ったいるけどハイパーリンクの有るセルを選択して設定URLに飛んでしまうので困る時と、リンクを開きたい時がある。
開く、開かないはシートイベントの有効無効で切り替える事にする。
関連記事 http://telstar.blog.so-net.ne.jp/2011-09-06

シートは下のURLを利用した。

ttp://www.eurus.dti.ne.jp/~yoneyama/Excel/kansu/itiran.html

 

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 'ハイパーリンクの有るセルを選択したら下に移動
 'シートにこのマクロを設定
 'シート名を右クリック「コードの表示」
 'ttp://www.excel.studio-kazu.jp/mag2/backnumber/mm20040727.html
 
    If Target.Hyperlinks.Count > 0 Then ' Targetにハイパーリンクcountがあれば

        ActiveCell.Offset(1, 0).Select ' ActiveCellの一つ下へ

    End If

End Sub

の、コードをシートマクロに記述する。

結果

マウスで選択すると、リンク先に飛ぶ、キーボードで選択した時は選択出来ないで下に移動する

ハイパーリンクの有るセルを選択出来ないようする、いい方法はないかなぁ

ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

ハイパーリンク関連資料

Sub ハイパーリンクの全削除()
'選択シートのハイパーリンクを全部削除する。
    ActiveSheet.Cells.Hyperlinks.Delete
End Sub

for i=1 to ActiveSheet.Hyperlinks.Count
        Cells(i, 1) = ActiveSheet.Hyperlinks(i).Range.Address 'セルのアドレス
        Cells(i, 2) = ActiveSheet.Hyperlinks(i).Address    'リンクのアドレス 
next i

ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

昼休みに考えた

ハイパーリンク一覧を別シートに作成 (セルアドレス、リンク内容)

無効にする ハイパーリンクの削除
有効にする ハイパーリンク一覧からハイパーリンクを設定する

近日公開予定 

 

 


タグ:Excel2000 VBA

EXCEL2000 VBA 文字の配置、縦配置を中央揃え  [Excel2000 VBA独習]

 EXCEL2000 VBA  文字の配置、縦配置を中央揃え 

ツールバーには、横方向の中央揃えのボタンは有るが、縦方向のは無いので?作った。

マクロで記録し利用する。

EXCEL2000VBA_V_S_01.png

マクロの記録では下記のコードになる。

 Sub Macro3()
'
' Macro3 Macro
' マクロ記録日 : 2012/10/17  ユーザー名 :
'

'
    Range("B1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .MergeCells = False
    End With

 End Sub

これに手を加えて下記のようにする。
不要なところは消してもいいが、一応のこしてコメントにする。

Sub 縦配置中央()
'
'
    With Selection
'        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
'        .WrapText = False
'        .Orientation = 0
'        .AddIndent = False
'        .ShrinkToFit = False
'        .MergeCells = False
    End With
End Sub


このマクロをツールバーに登録する。

 EXCEL2000VBA_V_S_02.png

 

 

 


タグ:Excel2000 VBA

EXCEL2000 VBA 選択範囲をHTMLとして保存する実験 [Excel2000 VBA独習]

EXCEL2000 VBA  選択範囲をHTMLとして保存する実験

Excel でhtmlで保存する操作をマクロに記録して利用した。

 

Sub 選択範囲HTML保存()
'
'選択範囲をHTMLで保存する
'
Dim saveDir_name As String '保存ディレクトリ、ファイル名

saveDir_name = "D:\nokie_bk\office\selectionHTML.html"
'

    ActiveWorkbook.PublishObjects.Add(xlSourceRange, saveDir_name, ActiveSheet.name, Selection.Address, xlHtmlStatic, "", "").Publish _
        (True)
End Sub

excelVBA_save_html_1.png

excelVBA_save_html_2.png

ソース

excelVBA_save_html_3.png

 

 


タグ:Excel2000 VBA

Excel2000VBA 選択セルから入力の有る最終行を選択する実験 [Excel2000 VBA独習]

 Excel2000VBA 選択セルから入力の有る最終行を選択

入力の有る最終行を 調べるには Range("A" & Rows.count)End(slUp).Row のようにするが、列をアルファベットにしなえらばならない。
そこで、Selection.Column で調べた列番号(数字)アルファベットに変換する方法を検索して調べたら下記のようにすると変換できる。(但しA-Zまで)Excel のAA-IVに変換は出来ない。

参考サイト  ttp://home.kanto-gakuin.ac.jp/~ahero/excel/vba/cell/cellActive.shtml

AA-IV列に対応できないが、一応作ってみた。

 excel_select_1.png

Sub 選択列の最終行まで選択()
'選択セル列の入力ある最終行まで選択する
'データ途中に空白があってもOK
'セル番号の数値からアルファベットへの変換 (A-Z列まで)
'ttp://home.kanto-gakuin.ac.jp/~ahero/excel/vba/cell/cellActive.shtml

Dim end_row As Long       '入力のある最終行番号
'
'end_row=Range("A" & Rows.count)End(slUp).Row
'列番号をアルファベットに変換 Chr(Asc("A") - 1 + ActiveCell.Column)
'選択されているセルの最終行 65536行から上方向調べ最初見つかったセル行番号

    end_row = Range(Chr(Asc("A") - 1 + Selection.Column) & Rows.Count).End(xlUp).Row
'範囲選択

    Range(Cells(Selection.Row, Selection.Column), Cells(end_row, Selection.Column)).Select

End Sub

------------------------------------------

以上の様な間抜けな事をしたので、もっとまともなマクロを作った。

Sub 選択セル列の最終行まで選択()
    Range(Selection(1), Cells(Rows.Count, Selection.Column).End(xlUp)).Select
End Sub

------------------------------------------

左上(selection(1)の入力の有る最終行を基準に複数列を選択

B10:C10を選択しマクロ実行画面

excel_select_2.png

 完成

Sub 選択セル列の最終行まで選択()
    Range(Selection(1), Cells(Rows.Count, Selection.Column).End(xlUp).Offset(0, Selection.Columns.Count-1)).Select
End Sub

追記

Ctrl +Shift + ↓で範囲選択するのと、どこが違うか?

Ctrl +Shift + ↓ では、空白セルの手前までしか選択できないが、上のマクロでは空白が途中にあっても入力のある最終行まで選択できる。

 資料
    Ctrl +Shift + ↓の動作をマクロで記録すると Range(Selection, Selection.End(xlDown)).Select

 

 

 


タグ:Excel2000 VBA

Excel2000VBA 選択範囲をソートする実験 [Excel2000 VBA独習]

Excel2000VBA 選択範囲をソートする実験

 EXCEL2000VBA_sort_01.png

Sub 選択範囲ソート2()
'あらかじめ範囲を選択する
'参考サイト ttp://excelvba.pc-users.net/fol7/7_4.html
'昇順で並べ替え「A~Z」、数値の場合は「0~9」
'降順で並べ替え「Z~A」、数値の場合は「9~0」
'------------------------------
'アクティブシートの選択範囲をソート(ソートキーを左上)
      ActiveSheet.Range(Selection.Address).Sort Key1:=ActiveSheet.Cells(Selection.Row, Selection.Column), order1:=xlAscending      'xlAscending (昇順に並び替える)
                                                                                                                                                                                                                      'xlDescending (降順に並び替える)
End Sub

-------------------------------------------------------------------------

 

Sub 選択範囲ソート降順()
'あらかじめ範囲を選択する
'参考サイト ttp://excelvba.pc-users.net/fol7/7_4.html
'昇順で並べ替え「A~Z」、数値の場合は「0~9」
'降順で並べ替え「Z~A」、数値の場合は「9~0」
'------------------------------
'アクティブシートの選択範囲をソート(ソートキーを左上)

ActiveSheet.Range(Selection.Address).Sort Key1:=ActiveSheet.Cells(Selection.Row, Selection.Column), order1:=xlDescending      'xlAscending (昇順に並び替える)
                                                                                                                                                                                                                      'xlDescending (降順に並び替える)
End Sub
Sub 選択範囲ソート昇順()
'あらかじめ範囲を選択する
'参考サイト ttp://excelvba.pc-users.net/fol7/7_4.html
'昇順で並べ替え「A~Z」、数値の場合は「0~9」
'降順で並べ替え「Z~A」、数値の場合は「9~0」
'------------------------------
'アクティブシートの選択範囲をソート(ソートキーを左上)

      ActiveSheet.Range(Selection.Address).Sort Key1:=ActiveSheet.Cells(Selection.Row, Selection.Column), order1:=xlAscending      'xlAscending (昇順に並び替える)
                                                                                                                                                                                                                      'xlDescending (降順に並び替える)
End Sub
 

 


Excel2000VBA 罫線の表示、非表示 [Excel2000 VBA独習]

Excel2000VBA 罫線の表示、非表示

excel_keisen_1-vert.png

Sub 罫線表示非表示()
If ActiveWindow.DisplayGridlines = True Then ActiveWindow.DisplayGridlines = False Else ActiveWindow.DisplayGridlines = True
End Sub

 


Excel2000VBA 郵便番号を展開して配列に入れる [Excel2000 VBA独習]

Excel2000VBA 郵便番号を展開して配列に入れる

ヤマトの送り状印刷の時に利用する為、郵便番号を分解して1文字づつ取り出す事にした。

 Excel_postnumber.jpg

Sub 郵便番号を展開して配列に入れる()
'実験
'
Dim postN(8) As String
Dim postNumber As String
Dim i As Integer

'選択している郵便番号を変数postnumberに代入
    postNumber = Selection.Value
'郵便番号を左から一文字づつ取り出し配列に入れる
    For i = 1 To 8
        postN(i) = Mid(postNumber, i, 1) 'Mid(文字列、左からの位置、取り出す文字数)
    Next
'結果表示
    For i = 1 To 8
        Cells(i, "A") = postN(i)
    Next
   

End Sub
 


Excel2000VBA 選択セルの値が同列に重複が有るか調べる [Excel2000 VBA独習]

Excel2000VBA 選択セルの値が同列に重複が有るか調べる。

ヤフオクで取引連絡の時、「はじめまして」と挨拶を書いてしまうのですが、実際2回目の取引だった事が何回か有り、取引相手様に失礼かも知れないので過去に取引が有ったか調べるマクロ作った。

記入項目
excel_yahoauction_1.jpg

excel_yahoauction_2.jpg

項目のID(取引相手のID)を利用してH列から重複を調べるマクロ(選択列)

Sub 列内で重複個数を調べる()
'選択しているセルの値と同じものが列全体に何個あるか調べる
'
Dim mykey As String     '調べる値
Dim myCol As Long       '調べる範囲(列番号)
Dim xRange As Range
Dim counter As Integer  'カウンター
Dim selCol As Range

'選択しているセルの値をmykeyに代入
    mykey = Selection.Value
'調べる列、選択しているセルの列
    myCol = Selection.Column
'列全体を選択
    Columns(myCol).Select
    Set selCol = Selection
'選択列から同じ値があるか調べ、個数を表示する
    For Each xRange In selCol
        If xRange.Value = mykey Then
        counter = counter + 1 '
        xRange.Interior.ColorIndex = 6   '該当するセルに背景色を付ける
        End If
    Next
'重複が有ったか?
    If counter - 1 = 0 Then
        MsgBox mykey & "の重複は有りません"
        Else: MsgBox mykey & " は" & counter & "個有りました"
    End If
Set selCol = Nothing
End Sub

 


タグ:Excel2000 VBA

Excel2000 VBA 全角、半角が混在する郵便番号を半角にする。 [Excel2000 VBA独習]

Excel2000 VBA 全角、半角が混在する郵便番号を半角にする。

コピペで入力した郵便番号を半角に統一したい時に簡単便利なVBA(ASC関数使用)

(ハイフンは記入されているものとする)

Sub 郵便番号半角()
’事前に範囲指定する
 Selection.Value = Application.Asc(Selection)
End Sub

excel_hankaku.jpg

参考にしたサイト

ttp://moug.net/tech/exvba/0140046.html

 


前の16件 | 次の16件 Excel2000 VBA独習 ブログトップ

この広告は前回の更新から一定期間経過したブログに表示されています。更新すると自動で解除されます。