1549662275 コピペマクロ制作にご協力ください。


メールなどクリップボード上にある、テキストデータをエクセルの所定の
場所にはりつけたいのです。詳しくは画像をご確認ください。

番号別に、A2行目から順番にはりつけたいと思っています。
しかし、文章が長くなったり、内側に改行コードがあると、エラーが出やすいようです。

それらを回避して貼り付けを実行願います。何も入っていないところは特に実行しなくて大丈夫です。

今後変えられるように、貼付の列番号の「A」や「AM」などは変えられるようにしておいていただけると
幸いです。

よろしくお願いいたします。

回答の条件
  • 1人1回まで
  • 13歳以上
  • 登録:2019/02/09 06:44:35
  • 終了:2019/02/16 06:45:05

回答(2件)

id:huumm No.1

フームー母回答回数5ベストアンサー獲得回数12019/02/09 12:30:40

ポイント100pt

画像を確認しましたが、文字がつぶれてみえませんでした。(こちらの環境のせいかもしれませんが)
画像を二つに分けて再投稿していただければ嬉しいです。

他15件のコメントを見る
id:huumm

うまくいかない原因が不明です…。コードの「'配列の最初が∇namae∇なら」の行の部分
 Cells(r, 1).Offset(1, 0) = arr2(i) を
→Cells(r, 1).Offset(1, 0) = Mid(arr2(i), 8)にすれば、Replaceを使わなくてもいけます。
具体的に言うと。

       If InStr(arr2(i), "∇namae∇") = 1 Then                   '配列の最初が∇namae∇なら
        Cells(r, 1).Offset(1, 0) = Mid(arr2(i), 8)                       'A列へ8文字目以降を転記(B列の2行目開始ならCells(r, 2).Offset(1, 0))
        ElseIf InStr(arr2(i), "∇shina∇") = 1 Then
        Cells(r, 3).Offset(1, 0) = Mid(arr2(i), 8)                       'C列へ8文字目以降を転記(C列の4行目開始ならCells(r, 3).Offset(3, 0))
        ElseIf InStr(arr2(i), "∇janco∇") = 1 Then
        Cells(r, 37).Offset(1, 0) = Mid(arr2(i), 8)
        ElseIf InStr(arr2(i), "∇zisya∇") = 1 Then
        Cells(r, 4).Offset(1, 0) = Mid(arr2(i), 8)
        ElseIf InStr(arr2(i), "∇hokan∇") = 1 Then
        Cells(r, 5).Offset(1, 0) = Mid(arr2(i), 8)
        ElseIf InStr(arr2(i), "∇soury∇") = 1 Then
        Cells(r, 8).Offset(1, 0) = Mid(arr2(i), 8)
        ElseIf InStr(arr2(i), "∇setum∇") = 1 Then
        Cells(r, 9).Offset(1, 0) = Mid(arr2(i), 8)
        ElseIf InStr(arr2(i), "∇saizu∇") = 1 Then
        Cells(r, 10).Offset(1, 0) = Mid(arr2(i), 8)
        ElseIf InStr(arr2(i), "∇kateg∇") = 1 Then
        Cells(r, 14).Offset(1, 0) = Mid(arr2(i), 8)
        ElseIf InStr(arr2(i), "∇kaisi∇") = 1 Then
        Cells(r, 20).Offset(1, 0) = Mid(arr2(i), 8)
        ElseIf InStr(arr2(i), "∇sokke∇") = 1 Then
        Cells(r, 65).Offset(1, 0) = Mid(arr2(i), 8)
        
        Else
        MsgBox "振り分けエラー"
        Exit Sub
        End If
        
    Next i

Else
    Open errtxt For Output As #1
    Print #1, buf2                            ''⑥-①のエラー判定に当てはまる場合、buf2をテキスト書き出し"
    Close #1
    MsgBox "エラー。読み取りデータが11の倍数ではありません。同じディレクトリにあるerrtxtabc.txtを確認してください。"
End If

End Sub



r = i ¥ 11 + 1の下の部分、後半をごっそり上記コードに入れ替えてください。
⑦を削除し、振り分けのコードを変えてます。

2019/02/19 10:33:28
id:huumm

こちらでは元データが確認できないため、エラー処理をわざわざ3つ設定してあります。こちらで決めた規則に元データが合致しなければ処理しないようにしてます。(本当は間違ってるのにもっともらしいデータができても困りますよね)そのため「うまくいかない」と感じられるのかもしれません。原因が分かれば修正は簡単だと思いますよ~。
ちなみに⑦のReplaceがうまくいかなかった原因が、私には分かりませんでした。
セルの各先頭が全て∇namae∇などになったままっていうことですよね?

後学のために質問なんですが、
A1セルに、 あいうえおかきくけこ 書いた状態で下記マクロを作動しても全然変わりません?もしよければ教えてください。

Sub aiueo()
Cells.Replace what:="あいうえお", Replacement:=""
End Sub

2019/02/19 10:58:29
id:naranara19

すみませんでした。
画像は「ファイルなう」にアップロードいたしました。
pngファイルですので、安全です。

よろしくお願いいたします。

【画像】
https://d.kuku.lu/7bbeae81b4

id:Z1000S No.2

空腹おやじ回答回数37ベストアンサー獲得回数252019/02/10 20:47:10

ポイント100pt

細かい部分の仕様がよくわからないので、
・クリップボードから取得したデータ
・データの先頭にある番号
・データを書き込む行
を指定して書き込むサンプルということで・・・

どうやって該当データを取り出して、
どうやって格納セルを設定するか
の参考になりますかね?

クリップボードからデータを取得するあたりは端折っているので
そのあたりは適当に細工して、うまく「addDatas」に渡してやってください。

Option Explicit

'参照設定:正規表現用
'Microsoft VBScript Regular Expressions 5.5


'データを書き込むワークシート名
Private Const TARGET_SHEET_NAME As String = "Sheet1"

'項目数
Private Const KEYS_COUNT        As Long = 11


Public Sub test()

    Dim sSampleData As String

    'クリップボードから取り出したと想定したデータ
    sSampleData = "502(517)" & vbCrLf & _
                "1名前書森県産" & vbCrLf & _
                "1品物りんご" & vbCrLf & _
                "1JANコード・ISBNコード12345" & vbCrLf & _
                "1自社カテゴリ果物" & vbCrLf & _
                "1保管場所A9" & vbCrLf & _
                "1送料宅配便1000" & vbCrLf & _
                "1説明糖度の高い、超お勧め品です。" & vbCrLf & _
                vbCrLf & _
                "1サイズ120" & vbCrLf & _
                "1カテゴリ678" & vbCrLf & _
                "1開始価格3000" & vbCrLf & _
                "1即決価格3500" & vbCrLf & _
                vbCrLf

    sSampleData = sSampleData & "503(518)" & vbCrLf & _
                "32名前愛媛県産" & vbCrLf & _
                "32品物みかん" & vbCrLf & _
                "32JANコード・ISBNコード23456" & vbCrLf & _
                "32自社カテゴリ果物" & vbCrLf & _
                "32保管場所B2" & vbCrLf & _
                "32送料宅配便800" & vbCrLf & _
                "32説明訳あり品ですが、甘くてお勧めです" & vbCrLf & _
                "32サイズ100" & vbCrLf & _
                "32カテゴリ234" & vbCrLf & _
                "32開始価格2000" & vbCrLf & _
                "32即決価格2200"

    Call addDatas(sSampleData, 1, 2)    '先頭の番号が"1"のデータを、2行目に書き込む
    Call addDatas(sSampleData, 3, 4)    '先頭の番号が"3"のデータがないので書き込まれない
    Call addDatas(sSampleData, 32, 5)   '先頭の番号が"32"のデータを、5行目に書き込む

End Sub

'sRecordData:クリップボードから取り出した文字列データ
'lNo        :各行の先頭にある数値
'lRow       :ワークシートへ書き込む行
Public Sub addDatas(ByVal sRecordData As String, ByVal lNo As Long, ByVal lRow As Long)

    Dim sTitles()   As String
    Dim sColumns()  As String
    Dim ws  As Worksheet
    Dim re  As RegExp
    Dim mc  As MatchCollection
    Dim i   As Long

    Call getTitleAndColumnDatas(sTitles, sColumns)

    Set ws = ThisWorkbook.Worksheets(TARGET_SHEET_NAME)

    Set re = New RegExp

    re.MultiLine = True

    For i = 0 To KEYS_COUNT - 1
        '検索するパターンの設定(先頭から、指定番号の後に指定したタイトルとなっている行)
        re.Pattern = "^" & CStr(lNo) & sTitles(i) & "(.+)\r\n"
        Set mc = re.Execute(sRecordData)

        If mc.Count = 1 Then
            'マッチするデータがあればワークシートに書き込む
            ws.Range(sColumns(i) & CStr(lRow)).Value = mc.Item(0).SubMatches(0)
        End If
    Next i

End Sub

'クリップボードから取り出した文字列データのタイトルと格納する列のデータを設定
Private Sub getTitleAndColumnDatas(ByRef sTitles() As String, ByRef sColumns() As String)

    '項目を追加、削除する場合は、上の方で宣言しているKEYS_COUNTの値の変更も忘れないこと
    ReDim sTitles(KEYS_COUNT - 1)
    ReDim sColumns(KEYS_COUNT - 1)

    sTitles(0) = "名前"
    sColumns(0) = "A"

    sTitles(1) = "品物"
    sColumns(1) = "C"

    sTitles(2) = "JANコード・ISBNコード"
    sColumns(2) = "AK"

    sTitles(3) = "自社カテゴリ"
    sColumns(3) = "D"

    sTitles(4) = "保管場所"
    sColumns(4) = "E"

    sTitles(5) = "送料"
    sColumns(5) = "H"

    sTitles(6) = "説明"
    sColumns(6) = "I"

    sTitles(7) = "サイズ"
    sColumns(7) = "J"

    sTitles(8) = "カテゴリ"
    sColumns(8) = "N"

    sTitles(9) = "開始価格"
    sColumns(9) = "T"

    sTitles(10) = "即決価格"
    sColumns(10) = "BM"

End Sub
他1件のコメントを見る
id:Z1000S

参照設定を行っていない為だと思われます。

以下のリンク先の「事前の準備」を参考にして
Microsoft VBScript Regular Expressions 5.5
にチェックをいれてから、再度実行してみてください。

VBAで正規表現を使う (1/3):CodeZine(コードジン)

2019/02/14 21:20:51
id:naranara19

すみませんでした。参照したあと実行しますと、
インデックスが有効範囲にありません。
とエラーが出てしまいます。

2019/02/16 04:32:17

コメントはまだありません

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

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

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

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