コメント欄にある動作をするマクロを作ってください。お気持ちのみですが合計で300P差し上げます(最初の方に重点配分)。1つは100pです。

pdfの表からエクセルファイルに表を移すときに生じたズレを修正するプログラムです。


よろしくお願い申し上げます。

回答の条件
  • 1人3回まで
  • 登録:2008/08/25 18:22:21
  • 終了:2008/08/28 14:05:06

ベストアンサー

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912008/08/25 19:27:22

ポイント300pt

一応仕様通りにしたつもりです。

仕様との違いがあれば、コメントください。


【1】

'-----------------------------------------------
Sub oneline()
'-----------------------------------------------
    Dim lastRow As Long
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
    
    Dim i As Long
    Dim flgJoin As Boolean
    
    Dim dstLastCol As Long
    Dim srcLastCol As Long
    
    Application.ScreenUpdating = False
    
    For i = lastRow To 2 Step -1
        flgJoin = False
        If IsNumeric(Cells(i, "A").Value) Then
            If (Len(Cells(i, "A").Value) > 3) Then
                flgJoin = True
            End If
        Else
            flgJoin = True
        End If
        If flgJoin = True Then
            dstLastCol = Cells(i - 1, 255).End(xlToLeft).Column
            srcLastCol = Cells(i, 255).End(xlToLeft).Column
            Range("A" & i).Resize(1, srcLastCol).Copy Destination:=Cells(i - 1, dstLastCol)
            Rows(i).Delete
        End If
    Next
    Application.ScreenUpdating = True
End Sub

【2】

'-----------------------------------------------
Sub del()
'-----------------------------------------------
    Dim lastRow As Long
    lastRow = Range("B" & Rows.Count).End(xlUp).Row
    
    Dim i As Long
    Dim ch As Variant
    
    Application.ScreenUpdating = False
    For i = 1 To lastRow
        For Each ch In Array(".", "/", "$", "%", "(", ")") '★ 削除する文字列
            Cells(i, "B").Value = Replace(Cells(i, "B").Value, ch, "")
        Next
    Next
    Application.ScreenUpdating = True
End Sub

【3-1】

'-----------------------------------------------
Sub delspace()
'-----------------------------------------------
    Dim lastRow As Long
    lastRow = Range("B" & Rows.Count).End(xlUp).Row
    
    Dim regEx
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Global = True
    

    Application.ScreenUpdating = False
    
    Dim i As Long

'--- 先頭の空白を削除
    regEx.Pattern = "^[  ]+"
    For i = 1 To lastRow
        Cells(i, "B").Value = regEx.Replace(Cells(i, "B").Value, "")
    Next

'--- 最後の空白を削除
    regEx.Pattern = "[  ]+$"
    For i = 1 To lastRow
        Cells(i, "B").Value = regEx.Replace(Cells(i, "B").Value, "")
    Next
    Application.ScreenUpdating = True

End Sub

【3-2】

'-----------------------------------------------
Sub joint()
'-----------------------------------------------
    Dim lastRow As Long
    lastRow = Range("B" & Rows.Count).End(xlUp).Row
    
    Dim regEx
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Global = True
    regEx.Pattern = "[  ]+"
    
    Application.ScreenUpdating = False
    
    Dim i As Long
    For i = 1 To lastRow
        Cells(i, "C").Value = regEx.Replace(Cells(i, "B").Value, "-")
    Next
    Application.ScreenUpdating = True
End Sub
id:ReoReo7

どうも、ありがとうございます!

2008/08/25 19:41:52

その他の回答(1件)

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912008/08/25 19:27:22ここでベストアンサー

ポイント300pt

一応仕様通りにしたつもりです。

仕様との違いがあれば、コメントください。


【1】

'-----------------------------------------------
Sub oneline()
'-----------------------------------------------
    Dim lastRow As Long
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
    
    Dim i As Long
    Dim flgJoin As Boolean
    
    Dim dstLastCol As Long
    Dim srcLastCol As Long
    
    Application.ScreenUpdating = False
    
    For i = lastRow To 2 Step -1
        flgJoin = False
        If IsNumeric(Cells(i, "A").Value) Then
            If (Len(Cells(i, "A").Value) > 3) Then
                flgJoin = True
            End If
        Else
            flgJoin = True
        End If
        If flgJoin = True Then
            dstLastCol = Cells(i - 1, 255).End(xlToLeft).Column
            srcLastCol = Cells(i, 255).End(xlToLeft).Column
            Range("A" & i).Resize(1, srcLastCol).Copy Destination:=Cells(i - 1, dstLastCol)
            Rows(i).Delete
        End If
    Next
    Application.ScreenUpdating = True
End Sub

【2】

'-----------------------------------------------
Sub del()
'-----------------------------------------------
    Dim lastRow As Long
    lastRow = Range("B" & Rows.Count).End(xlUp).Row
    
    Dim i As Long
    Dim ch As Variant
    
    Application.ScreenUpdating = False
    For i = 1 To lastRow
        For Each ch In Array(".", "/", "$", "%", "(", ")") '★ 削除する文字列
            Cells(i, "B").Value = Replace(Cells(i, "B").Value, ch, "")
        Next
    Next
    Application.ScreenUpdating = True
End Sub

【3-1】

'-----------------------------------------------
Sub delspace()
'-----------------------------------------------
    Dim lastRow As Long
    lastRow = Range("B" & Rows.Count).End(xlUp).Row
    
    Dim regEx
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Global = True
    

    Application.ScreenUpdating = False
    
    Dim i As Long

'--- 先頭の空白を削除
    regEx.Pattern = "^[  ]+"
    For i = 1 To lastRow
        Cells(i, "B").Value = regEx.Replace(Cells(i, "B").Value, "")
    Next

'--- 最後の空白を削除
    regEx.Pattern = "[  ]+$"
    For i = 1 To lastRow
        Cells(i, "B").Value = regEx.Replace(Cells(i, "B").Value, "")
    Next
    Application.ScreenUpdating = True

End Sub

【3-2】

'-----------------------------------------------
Sub joint()
'-----------------------------------------------
    Dim lastRow As Long
    lastRow = Range("B" & Rows.Count).End(xlUp).Row
    
    Dim regEx
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Global = True
    regEx.Pattern = "[  ]+"
    
    Application.ScreenUpdating = False
    
    Dim i As Long
    For i = 1 To lastRow
        Cells(i, "C").Value = regEx.Replace(Cells(i, "B").Value, "-")
    Next
    Application.ScreenUpdating = True
End Sub
id:ReoReo7

どうも、ありがとうございます!

2008/08/25 19:41:52
id:taknt No.2

きゃづみぃ回答回数13537ベストアンサー獲得回数11982008/08/25 19:55:58

ポイント100pt
Sub oneline()
    Dim b As Long
    d = 2
    For a = 2 To 65536
        If Cells(d, 1) = "" Then Exit For
        b = Val(Cells(d, 1))
        If b <> Cells(d, 1) Then
            For c = 1 To 256
                If Cells(d - 1, c) = "" Then Exit For
            Next c
            
            For e = 1 To 256
                If Cells(d, e) = "" Then
                    Rows(d).Delete
                    d = d - 1
                    Exit For
                Else
                    Cells(d - 1, c) = Cells(d, e)
                    c = c + 1
                End If
            Next e
        End If
        
        d = d + 1
    Next a
End Sub

Sub del()
    'カラム2行目だけ削除
    Columns(2).Replace ".", ""
    Columns(2).Replace "/", ""
    Columns(2).Replace "%", ""
    Columns(2).Replace "(", ""
    Columns(2).Replace "$", ""
    Columns(2).Replace ")", ""
End Sub

Sub delspace()
    For a = 1 To 65536
        If Cells(a, 2) = "" Then Exit For
        Cells(a, 2) = Trim(Cells(a, 2))
    Next a
End Sub

Sub joint()
    For a = 255 To 2 Step -1
        Columns(2).Replace Space(a), " "
    Next a


    For a = 1 To 65536
        If Cells(a, 2) = "" Then Exit For
        Cells(a, 3) = Cells(a, 2)
    Next a
    
    Columns(3).Replace " ", "-"
    
End Sub


一番目のがちょっと面倒でしたね。

id:ReoReo7

いつもありがとうございます。参考にさせて頂きます。やはりちょっと面倒でしたか...

PDFの表をExcelにするのにいい方法ってないんでしょうかね?

2008/08/25 20:50:42
  • id:ReoReo7
    1:sub oneline()
    以下の表Aのように並んでいるデータを、表Bのように1列にする

    表A
    [col1] [col2][col3] [col4]
    [row1] 1 asdf asdf adsf
    [row2] 2 asdf asdfs asdf
    [row3] 3 asdf
    [row4] asdf asdf
    [rown] (ランダムな数字) (ランダムな文字列) (ランダムな文字列) (ランダムな文字列)

    表B
    [col1] [col2][col3] [col4]
    [row1] 1 asdf asdf adsf
    [row2] 2 asdf asdfs asdf
    [row3] 3 asdf asdf asdf
    [row4] (row5にあるデータ)

    説明:行nのcol1にあるのが数字(1桁~3桁)以外であった場合、行n-1の最後の列の続きに結合し、行nを削除する。
    (250行あるので、動作スピードをあげるため削除する際は描画をとめてください)

    2:sub del()
    col2の各セル(string)の文字列に./%$()の5つの文字があれば削除する。
    たとえば、表Aがあったら表Bのようにする。

    表A
    [col1] [col2]
    [row1] 1 as2df / no.3
    [row2] 2 a/sdf (descr)

    表B
    [col1] [col2]
    [row1] 1 as2df no3
    [row2] 2 asdf descr


    3-1:sub delspace()
    列2の文字列の最初か最後にスペース(大文字または小文字)があれば削除する。

    3-2:sub joint()
    列2のスペース(1つか複数幅)を削除し、-をひとつ挿入して列3に書き込む
    たとえば、表Aがあったら表Bのようにする。

    表A
    [col1] [col2]
    [row1] 1 as2df no3
    [row2] 2 asdf descr

    表B
    [col1] [col2] [col3]
    [row1] 1 as2df no3 as2df-no3
    [row2] 2 asdf descr asdf-descr
  • id:taknt
    http://www.sourcenext.com/titles/use/92000/?i=new

    いきなり PDF to Data EX

    このソフトを使えば、PDFをエクセルファイルにすることができます。


  • id:Mook
    del と delspace は taknt さんの方が効率的ですね。

    最初私も delspace は trim を使用したのですが、全角スペースを考慮して正規表現にしました。
    でも、trim は全角も対応していたんですね。

    sub joint は同じく正規表現で複数の空白に対応しています。
  • id:Mook
    多くのポイントをもらった後で申し訳ありませんが、
    1番の回答に問題がありました。

      dstLastCol = Cells(i - 1, 255).End(xlToLeft).Column

      dstLastCol = Cells(i - 1, 255).End(xlToLeft).Column + 1
    にしてください。

    最後のセルが、欠けてしまいます。
    失礼しました。
  • id:ReoReo7
    おかげさまで所望の動作を得られました。ありがとうございます。

    takntさん
    ご紹介、ありがとうございます。機会があれば使ってみたいと思います。

    Mookさん

    了解しました。ありがとうございます!

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

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

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

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