人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

エクセルのマクロについて質問です。お気持ちのみですが合計で200p?差し上げます。
エクセルファイルに書かれたある範囲を、テキストデータとして出力するマクロを作ってください。
具体的には、現在下の作業を手作業で行っているところをマクロで行えるようにしたいです。

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

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

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



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



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

●質問者: ReoReo7
●カテゴリ:コンピュータ ウェブ制作
✍キーワード:b2 エクセル コピー セル テキスト
○ 状態 :終了
└ 回答数 : 5/5件

▽最新の回答へ

1 ● KRM
●20ポイント

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

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

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

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


2 ● きゃづみぃ
●100ポイント ベストアンサー

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

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

◎質問者からの返答

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

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

1)

PublicConst GHND = &H42

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

2)

Declare Function OpenClipboard Lib ・・・

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

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


〔追記〕

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

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


3 ● arhbwastrh
●50ポイント

使用方法

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
<||
◎質問者からの返答

ありがとうございます。

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


4 ● Mook
●50ポイント

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

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

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
◎質問者からの返答

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

早速ためしてみます。

〔追記〕

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

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


5 ● ardarim
●100ポイント

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

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
◎質問者からの返答

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


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

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ