エクセルのマクロについて質問です。お気持ちのみですが合計で200p~差し上げます。

エクセルファイルに書かれたある範囲を、テキストデータとして出力するマクロを作ってください。
具体的には、現在下の作業を手作業で行っているところをマクロで行えるようにしたいです。

1)「B3:G169」に書かれたデータを(文字列として)テキストエディタ(メモ帳)にコピー&ペーストする。
2)ファイル名を「(B2に書かれた文字列)」として保存する。

3)「N171:T199」に書かれたデータをテキストエディタにコピー&ペースト
4)ファイル名を「(N170に書かれた文字列)」として保存する。

5)このようなファイルを更に6つ作る(範囲とファイル名を示すセルが異なっている)。



1)や3)でコピー&ペーストする際、横となりのセルに書かれている文字列どうしは最低1文字のスペース(インデント?)の間隔を持つことと、縦どなりのセルに書かれている文字列どうしが改行されているが重要となっています。また数式ではなく計算結果を文字列として出力します。(普通にメモ帳にコピー&ペーストしたらこの動作は得られます。)



お力を貸してください。よろしくお願いします。

回答の条件
  • 1人5回まで
  • 登録:2006/11/02 22:36:24
  • 終了:2006/11/08 17:54:31

ベストアンサー

id:taknt No.2

きゃづみぃ回答回数13539ベストアンサー獲得回数11982006/11/02 23:43:28

ポイント100pt

Declare Function OpenClipboard Lib "User32" _

(ByVal hwnd As Long) As Long

Declare Function CloseClipboard Lib "User32" _

() As Long

Declare Function GetClipboardData Lib "User32" _

(ByVal wFormat As Long) As Long

Declare Function GlobalAlloc Lib "kernel32" _

(ByVal wFlags&, _

ByVal dwBytes As Long) As Long

Declare Function GlobalLock Lib "kernel32" _

(ByVal hMem As Long) As Long

Declare Function GlobalUnlock Lib "kernel32" _

(ByVal hMem As Long) As Long

Declare Function GlobalSize Lib "kernel32" _

(ByVal hMem As Long) As Long

Declare Function lstrcpy Lib "kernel32" _

(ByVal lpString1 As Any, _

ByVal lpString2 As Any) As Long

Public Const GHND = &H42

Public Const CF_TEXT = 1

Public Const MAXSIZE = 4096


Function ClipBoard_GetData()

Dim hClipMemory As Long

Dim lpClipMemory As Long

Dim MyString As String

Dim RetVal As Long

If OpenClipboard(0&) = 0 Then

MsgBox "クリップボードが開きません"

Exit Function

End If

' テキストを参照しているグローバル メモリ

' のブロックへのハンドルを取得します。

hClipMemory = GetClipboardData(CF_TEXT)

If IsNull(hClipMemory) Then

MsgBox "Could not allocate memory"

GoTo OutOfHere

End If

' クリップボードのメモリをロックし、実際の

' データ文字列を参照します。

lpClipMemory = GlobalLock(hClipMemory)

If Not IsNull(lpClipMemory) Then

MyString = Space$(MAXSIZE)

RetVal = lstrcpy(MyString, lpClipMemory)

RetVal = GlobalUnlock(hClipMemory)

' null 終了文字を削除します。

MyString = Mid(MyString, 1, InStr(1, MyString, Chr$(0), 0) - 1)

Else

MsgBox "Could not lock memory to copy string from."

End If

OutOfHere:

RetVal = CloseClipboard()

ClipBoard_GetData = MyString

End Function

Sub Macro1()

'

' Macro1 Macro

'

' Keyboard Shortcut: Ctrl+q

'

Dim Stream As Object

'Dim CB As New DataObject

Dim buf As String

Set Stream = CreateObject("ADODB.Stream")

'ファイル名セット

f = Range("B2")

Range("B3:G169").Copy

buf = ClipBoard_GetData

Stream.Open

Stream.Type = 2

Stream.writeText (buf)

Stream.SaveToFile f, 2

Stream.Close

End Sub

http://www.moug.net/tech/acvba/0020008.htm

クリップボードからテキストを取り出す箇所は、上記のURLを利用しました。

f = Range("B2")

Range("B3:G169").Copy

この二箇所を変更して、他に対応してください。

id:ReoReo7

大変ご丁寧にありがとうございます。

以下の2箇所でエラーが出るようです。

1)

PublicConst GHND = &H42

(Public ConstではなくPublicConstですよね?)で、「プロシージャの外では無効です」とのエラーメッセージ

2)

Declare Function OpenClipboard Lib ・・・

で、「・・・Declareステートメントは、オブジェクトモジュールのパブリックメンバとして定義できません」のエラーメッセージが、それぞれ出ます。

どのようにしたら、よろしいでしょうか?


〔追記〕

おかげさまで実行できました。

エラーも回避できました。

2006/11/03 01:33:51

その他の回答(4件)

id:KRM No.1

KRM回答回数27ベストアンサー獲得回数62006/11/02 23:14:50

ポイント20pt

http://www.h7.dion.ne.jp/~umiumi/

UWSCでCOMオブジェクト操作するのが早いでしょうか。

ヘルプファイルのスクリプト->スクリプト関数->COMオブジェクト->COMオブジェクト生成の項の「例」でExcel操作の例(これは値設定の例ですが)を参考にして、

これとExcelのマクロのヘルプを見ながらで作れると思います。

id:taknt No.2

きゃづみぃ回答回数13539ベストアンサー獲得回数11982006/11/02 23:43:28ここでベストアンサー

ポイント100pt

Declare Function OpenClipboard Lib "User32" _

(ByVal hwnd As Long) As Long

Declare Function CloseClipboard Lib "User32" _

() As Long

Declare Function GetClipboardData Lib "User32" _

(ByVal wFormat As Long) As Long

Declare Function GlobalAlloc Lib "kernel32" _

(ByVal wFlags&, _

ByVal dwBytes As Long) As Long

Declare Function GlobalLock Lib "kernel32" _

(ByVal hMem As Long) As Long

Declare Function GlobalUnlock Lib "kernel32" _

(ByVal hMem As Long) As Long

Declare Function GlobalSize Lib "kernel32" _

(ByVal hMem As Long) As Long

Declare Function lstrcpy Lib "kernel32" _

(ByVal lpString1 As Any, _

ByVal lpString2 As Any) As Long

Public Const GHND = &H42

Public Const CF_TEXT = 1

Public Const MAXSIZE = 4096


Function ClipBoard_GetData()

Dim hClipMemory As Long

Dim lpClipMemory As Long

Dim MyString As String

Dim RetVal As Long

If OpenClipboard(0&) = 0 Then

MsgBox "クリップボードが開きません"

Exit Function

End If

' テキストを参照しているグローバル メモリ

' のブロックへのハンドルを取得します。

hClipMemory = GetClipboardData(CF_TEXT)

If IsNull(hClipMemory) Then

MsgBox "Could not allocate memory"

GoTo OutOfHere

End If

' クリップボードのメモリをロックし、実際の

' データ文字列を参照します。

lpClipMemory = GlobalLock(hClipMemory)

If Not IsNull(lpClipMemory) Then

MyString = Space$(MAXSIZE)

RetVal = lstrcpy(MyString, lpClipMemory)

RetVal = GlobalUnlock(hClipMemory)

' null 終了文字を削除します。

MyString = Mid(MyString, 1, InStr(1, MyString, Chr$(0), 0) - 1)

Else

MsgBox "Could not lock memory to copy string from."

End If

OutOfHere:

RetVal = CloseClipboard()

ClipBoard_GetData = MyString

End Function

Sub Macro1()

'

' Macro1 Macro

'

' Keyboard Shortcut: Ctrl+q

'

Dim Stream As Object

'Dim CB As New DataObject

Dim buf As String

Set Stream = CreateObject("ADODB.Stream")

'ファイル名セット

f = Range("B2")

Range("B3:G169").Copy

buf = ClipBoard_GetData

Stream.Open

Stream.Type = 2

Stream.writeText (buf)

Stream.SaveToFile f, 2

Stream.Close

End Sub

http://www.moug.net/tech/acvba/0020008.htm

クリップボードからテキストを取り出す箇所は、上記のURLを利用しました。

f = Range("B2")

Range("B3:G169").Copy

この二箇所を変更して、他に対応してください。

id:ReoReo7

大変ご丁寧にありがとうございます。

以下の2箇所でエラーが出るようです。

1)

PublicConst GHND = &H42

(Public ConstではなくPublicConstですよね?)で、「プロシージャの外では無効です」とのエラーメッセージ

2)

Declare Function OpenClipboard Lib ・・・

で、「・・・Declareステートメントは、オブジェクトモジュールのパブリックメンバとして定義できません」のエラーメッセージが、それぞれ出ます。

どのようにしたら、よろしいでしょうか?


〔追記〕

おかげさまで実行できました。

エラーも回避できました。

2006/11/03 01:33:51
id:arhbwastrh No.3

arhbwastrh回答回数447ベストアンサー獲得回数232006/11/02 23:48:33

ポイント50pt

使用方法

1 Sheet2のA2にファイルパスを最後の円マークまで、A1にファイルパスを入力します

2 出力したい範囲を選択します

3 マクロを実行します

※マクロの記録でショートカットキーを割り当て、そこにこのコードをコピーすると便利です。

また、説明書きを入れてあるので、便利になるようカスタマイズしてみてください。

※Sheet2,3はそれぞれ左から2,3番目(つまり、デフォルトの状態)になっている必要があります。また、Sheet2とSheet3という名前のシートがないとエラーになります。


Sub test()
Selection.Copy
Sheets("Sheet3").Select 'Sheet3は実際保存されるシートです。
Range("A1").Activate '左上づめになるようにしてあります。
ActiveSheet.Paste

    ActiveWorkbook.SaveAs Filename:= _
        Worksheets(2).Range("A2") & Worksheets(2).Range("A1") & ".txt", FileFormat:=xlUnicodeText, _
        CreateBackup:=False
        '2番目のシートのA2にファイルパスが入っていると認識されるようになっています。
        'また、A1にファイル名が入っていると認識されるようになっています。
        
        Sheets(3).Name = "Sheet3"
    
End Sub
<||
id:ReoReo7

ありがとうございます。

メモ帳などに保存するのではなく、エクセルの違うシートにコピーするマクロでしょうか?

2006/11/03 01:33:58
id:Mook No.4

Mook回答回数1312ベストアンサー獲得回数3912006/11/03 00:25:02

ポイント50pt

メモ帳で保存することではなく、テキストファイルとして保存することが目的だと思いましたので、メモ帳は使っていません。

メモ帳で開くことも重要でしたら、必要でしたら補足いたします。

Const Separater = " " ' 区切りをスペース1文字にする場合
' Const Separater = vbTab ' 区切りをタブにする場合

'------------------------------------------------------------
Sub makeFiles()
'------------------------------------------------------------
' saveFile の第一引数にセル範囲、第二引数にファイル名をしてします。
    Call saveFile("B3:G169", Cells(2, "B").Value)
    Call saveFile("N171:T199", Cells(170, "N").Value)
End Sub

'------------------------------------------------------------
Sub saveFile(rangeArea As String, fileName As String)
'------------------------------------------------------------
    Dim filePath As String
    filePath = ThisWorkbook.Path &amp; "\" &amp; fileName
    Dim dataRange As Range
    On Error Resume Next
'---- レンジの指定範囲のチェック
   Set dataRange = ActiveSheet.Range(rangeArea)
    On Error GoTo 0
    If dataRange Is Nothing Then
        MsgBox "Bad Range [" &amp; rangeArea &amp; "]"
        Exit Sub
    End If
'---- ファイルの書き込み処理
    Dim RowStart%, RowEnd%, RowIndex%    '--- 変数を整数型として宣言
    RowStart = dataRange.Row
    RowEnd = dataRange.Row + dataRange.Rows.Count - 1
    
    Dim ColStart%, ColEnd%, ColIndex
    ColStart = dataRange.Column
    ColEnd = ColStart + dataRange.Columns.Count - 1
        
    Dim oneLine As String
    With CreateObject("Scripting.FileSystemObject")
        With .createTextFile(filePath)
        For RowIndex = RowStart To RowEnd
'---- 1行の作成
            oneLine = Cells(RowIndex, ColStart).Value
            For ColIndex = ColStart + 1 To ColEnd
                oneLine = oneLine &amp; Separater &amp; Cells(RowIndex, ColIndex).Value
            Next
            .writeLine oneLine          '---- 1行の出力
        Next
        .Close                          '---- ファイルのクローズ
        End With
    End With
End Sub
id:ReoReo7

テキストエディタでしたらなんでもよいです。

早速ためしてみます。

〔追記〕

おかげさまで実行できました。

動作も快適・かつ使いやすいです。

2006/11/03 02:11:08
id:ardarim No.5

ardarim回答回数896ベストアンサー獲得回数1442006/11/03 01:23:29

ポイント100pt

こんな感じでどうでしょうか。

Option Explicit

Sub test()

    SaveAsText "B3:G169", "B2"
    SaveAsText "N171:T199", "N170"

    ' 以下、必要な分だけ繰り返し...

End Sub

Sub SaveAsText(saveRangeString As String, filenameString As String)

    Dim saveRange As Range
    Dim filenameToSave As String
    Dim fn As Integer
    Dim r As Range, c As Range
    Dim sp As String

    Set saveRange = ActiveSheet.Range(saveRangeString)
    filenameToSave = Range(filenameString).Value

    fn = FreeFile()
    Open filenameToSave For Output As #fn
    
    For Each r In saveRange.Rows
        sp = ""
        For Each c In r.Cells
            Print #fn, sp & c.Value;
            sp = " "
        Next c
        Print #fn, ""
    Next r
    
    Close #fn

End Sub
id:ReoReo7

大変快適に動作しました。


皆さんのおかげで勉強でき所望の動作も得られました。ありがとうございました。深く感謝いたします。

2006/11/03 02:11:40
  • id:taknt
    '
    ' Macro1 Macro
    '
    ' Keyboard Shortcut: Ctrl+q
    '
    より 上の部分は、提示したURLのところのものをコピーしてきてください。

    あと、標準モジュールのほうに記述してください。

    私のほうでは エラーは出ませんでした。
    Excel2003ですが。

  • id:ReoReo7

    takntさんありがとうございます。
    標準モジュールに書いていなかったのが原因であったようです。
    その問題は解決し、実行ができました。

    現在、結果を見ています。
  • id:ReoReo7
    >arhbwastrhさん
    ありがとうございます。
    プログラムが短いので不思議に思っていましたが、そうなんですね。
    失礼しました。

    ありがとうございます。
    早速試してみたいと思います。
  • id:Mook
    御存知かもしれませんが、「&」 が 「&amp;」 になってしまっているので、修正してお使いください。

    スーパーpre記法の不具合のようです。
  • id:ReoReo7
    takntさんありがとうございました。
    おかげさまで所望の動作を得ることができました。

    興味深いのでほかの方のプログラムも実行してみます。
  • id:ReoReo7
    Mookさん、了解しました。
  • id:ReoReo7
    皆様ありがとうございました。

    複数の方にわずかな時間差で回答いただきました。

    皆様のすべてのプログラムをためさせていただきました。
    いずれもコメントに記したとおり動作できました。

    最初にご提示いただいたのがtakntさんのプログラム、
    実際に使用したプログラムがardarinさんのプログラムであったことを考慮してポイント300ポイントを分配させていただきました。

    多少の分配の方よりは感じられるかもしれませんが、複数の方がほぼ同時にご提示いただいたということで、このような分配にさせていただきました。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません