エクセル2003にて VBA初心者です。

以下のようなデータがあります。
 列A    列B     列C
 識別   部品番号  ユニット
        A10000   *100
        A10001   *101
        A10002   *102
 *     A10002   *103
        A10003   *104
 *     A10003   *105
 *     A10003   *106
 ・        ・      ・
 ・        ・      ・
 ・        ・      ・

列Bには部品番号が、列Cにはユニット名が記入されています。
同じ部品番号でもユニットが異なる場合には、列Aに*が記入されています。
このようなデータが20,000行ほどあります。

上記のようなデータを以下のように並べ替えたいと考えております。
 列A    列B      列C     列D     列E
 識別   部品番号   ユニット   ユニット  ユニット
       A10000    *100
       A10001    *101
       A10002    *102     *103
       A10003    *104     *105     *106

VBAを利用すればできるんだろうなーと思っていますが、
見当もつきません。
どうぞよろしくお願いいたします。

このQ&Aに関連する最新のQ&A

A 回答 (8件)

サンプルです。



Sub Macro()
  Dim rng As Range
  Dim i As Long
  Dim j As Long
  
  Set rng = Range("A3", "A" & Range("B" & Rows.Count).End(xlUp).Row)
  Set rng = rng.SpecialCells(xlCellTypeConstants, 2)
  For i = 1 To rng.Areas.Count
    For j = 1 To rng.Areas(i).Count
      With rng.Areas(i).Item(j)
        .Offset(-j, j + 2).Value = .Offset(, 2).Value
      End With
    Next j
  Next i
  rng.EntireRow.Delete
End Sub

>VBAを利用すればできるんだろうなーと思っていますが、
>見当もつきません。
手作業ではどうしますか?
手作業を「マクロの記録」すれば参考コードが得られます。
    • good
    • 0
この回答へのお礼

さっそくのご回答ありがとうございます。

このサンプルを実行すると、
C列のデータが一行目のD列から最終列(IV列)まで転写され
エラーメッセージが出てしまいます。

私のやり方がどこかまずいのでしょうか?
それともサンプルはあくまでもサンプルであり、
このサンプルをベースにIF文等を加えないと問題は解決できない
ということなのでしょうか?

重ね重ねの質問で申し訳ありませんがよろしくお願い致します。

お礼日時:2009/05/16 16:10

Wendy02さん


>rng.Columns(1).Value = rng.Columns(1).Value
「参考になった」ボタンをClickしました。
ありがとうございました。

""以外に、スペース、Alt+Enter、CHAR(10)等にも対応できないか考えてみました。
nankoro_xさんの補足によれば「*」セル以外は「空白」セルという認識で問題ないようです。
「セル選択」で「選択オプション」にある「アクティブ列との相違」を利用し

Dim frng As Range

Set rng = Range("A4", "A" & Range("B" & Rows.Count).End(xlUp).Row)
With rng
  Set frng = .Find(what:="*", After:=.Cells(.Count), LookIn:=xlValues)
End With
rng.ColumnDifferences(frng).ClearContents
Set rng = rng.SpecialCells(xlCellTypeConstants, 2)

と、こんな風にしてみましたが、どうでしょうか。
    • good
    • 0

xls88さん


nankoro_xさん

こんばんは。

xls88さん、私の書いたものを読んでいただきありがとうございました。
#1のコードを試して、私が試した方法は、一旦、数式を作っておいて、それを値貼り付けしてみました。目では、"" は消えているのですが、SpecialCells を試してみると、Area が、ひとつにまとまってしまいました。

そこで、私の一案ですが、

Set rng = Range("A3", "A" & Range("B" & Rows.Count).End(xlUp).Row) 
rng.Columns(1).Value = rng.Columns(1).Value '←このコードを入れてみました。
Set rng = rng.SpecialCells(xlCellTypeConstants, 2)

私の作ったサンプルの場合は、成功しました。
ご質問者さんに対しては、必ず上手くいくとは保証できないのですが、「"" 」残っている場合は、.Value = .Value で消せるのです。
    • good
    • 0
この回答へのお礼

ご指摘ありがとうございます。
無事に問題を解決することができました。

お礼日時:2009/05/17 07:59

>先ほどのプログラムの意味を調べる所から始めてみます。


是非そうしてください。
その姿勢があれば、必ずVBAの使い手として上達されると思います。
解らないところがあれば、遠慮なく補足してください、解る範囲でお答えしたいと思います。

私が提示したコードは、A列で、文字(「*」に限らない)が入力されているセルを抽出し、その後の処理の基準にしています。
問題は、Wendy02さんが指摘されているように、空白セルは、実は空白ではなく空白に見えているセルだということだと思います。
1行目ではなく、2行目に転記されるということは、A2セルのみ真正の空白セルだと思います。

先のコードに、★のところを追加してみてください。

Set rng = rng.SpecialCells(xlCellTypeConstants, 2)
MsgBox rng.Address '★

実行すると、メッセージボックスにセル範囲アドレスが表示されます。
空白に見えるセルが、表示されたセル範囲に含まれていると思います。
対応策が、他の方々から提案されています。参考にしてください。
他には、検索で、*セルを抽出する手もあるとおもいます。

ご存知かもしれませんが
VBEのコードウィンドウで、調べたい単語の中に文字カーソルを置いた状態で、F1キーを押してください。
目的の単語のページにジャンプして、ヘルプが表示されます。

デバッグについて
http://members.jcom.home.ne.jp/rex-uchida/vba110 …
ブレークポイント
http://www.vba-world.com/breakpoint.html
    • good
    • 0
この回答へのお礼

いろいろとご教授頂きありがとうございます。

無事に解決することができました。
本当にありがとうございます。

A列ですが、
=IF(COUNTIF($B$2:B2,B2>1),"*","")
という関数で二個目以降の同一部品番号に*をつけた後、
値コピーしたものです。
値コピーすれば空白か*のみになると考えておりました。
私の前提条件の提示が足りませんでした。
申し訳ございませんでした。

xls88様のコードに、Wendy02様の提示された1行を追加したところ
うまくいきました。
本当にありがとうございました。

お礼日時:2009/05/17 07:54

>このサンプルをベースにIF文等を加えないと問題は解決できない


ということなのでしょうか?

そうですね。そう思います。
質問文にあるとおりのデータを手で入力して、#01さんのマクロを実行すればちゃんと動きます。試されましたか?
それが動かないとすれば「実際のデータには質問文に書かれていない『何か』があるから」ではないでしょうか。

例えば「部品番号が昇順になっていなくて同じ番号が繰り返し出現する」、「一つの部品番号が256以上のユニットで利用されている」、「A列の*は関数で表示している」などです。

実際のデータが分からないのでB列、C列のデータだけで処理するようにしてみました。A列のデータに意味があるならご自身で書き換えてください

Sub Macro1()
Dim ws As Worksheet
Dim idx, ptr As Long
Dim trg As Range
  Set ws = ActiveSheet
  On Error GoTo end0
  Application.ScreenUpdating = False
  Worksheets.Add after:=ws
  With ws
    .Rows(1).Copy Destination:=Rows(1)
    For idx = 2 To .Range("B65536").End(xlUp).Row
      If .Cells(idx, "B").Value <> "" Then
        Set trg = ActiveSheet.Columns(2).Find(what:=.Cells(idx, "B").Value, _
              LookIn:=xlValues, Lookat:=xlWhole)
        If trg Is Nothing Then
          Range("B65536").End(xlUp).Offset(1, 0).Value = .Cells(idx, "B").Value
          ptr = Range("B65536").End(xlUp).Row
        Else
          ptr = trg.Row
        End If
        If Application.CountIf(Rows(ptr), .Cells(idx, "C").Value) = 0 Then
          If Cells(ptr, "IV").Value = "" Then
            Cells(ptr, "IV").End(xlToLeft).Offset(0, 1).Value = _
              .Cells(idx, "C").Value
          Else
            MsgBox "列数が256を超えるので処理できません"
            Exit For
          End If
        End If
        Set trg = Nothing
      End If
    Next idx
  End With
end0:
  Application.ScreenUpdating = True
End Sub
    • good
    • 0
この回答へのお礼

無事に問題を解決することができました。
ありがとうございました。

お礼日時:2009/05/17 08:00

こんにちは。



まず、#1さんのコードは、問題ないはずなのですが、その「識別」が付けられた過程を考えたときに、数式でできていたのではないでしょうか。仮に、文字として、定数になっていても、空白部分が完全に空白になっていないのではないか、と思います。値貼り付けでは、どうやら痕跡が残るようですから、SpecialCells 以外のマクロによる、完全空白する処理が必要かもしれません。

そこで、私は、その質問の表を見たときに、その「識別」をまったくアテにしないことを考えました。2万行ということになると、最後まで信頼置けないような気がしました。そこで、「識別」を頼りにせず、独自に、配列で確保しながら、配列を使って、表を作ることにしました。データが、20,000件ですから、まあ、そこそこに動くレベルだと思います。それ以上のスピードを稼ぐものは、あまり思い当たらないです。

以下は、シート2に書き出すようにはなっていますが、その設定は、任意にしてください。

Sub ArrangeLines()
  '部品番号はソートされていることが条件
  Dim sh1 As Worksheet
  Dim sh2 As Worksheet
  Dim rng As Range
  Dim i As Long, j As Long, k As Long
  Dim mx As Integer
  Dim v As Variant
  Dim ar As Variant
  Dim ar2 As Variant
  Dim art()
  Dim arb() As String
  Dim buf As String
  Dim flg As Boolean
  '-------------------------------------------
  Set sh1 = Worksheets("Sheet1") 'オリジナル・データシート
  Const O As String = "A1" 'オリジナルデータの左上端
  
  Set sh2 = Worksheets("Sheet2") 'データの書き出しシート
  Const P As String = "A1" 'データの書き出し場所端
  '-------------------------------------------
  With sh1
    Set rng = .Range(O).Range("B1", .Range("B65536").End(xlUp))
  End With
  sh2.Range(P).CurrentRegion.ClearContents
  ar = Application.Transpose(rng.Offset(1).Value)
  ar2 = Application.Transpose(rng.Offset(1, 1).Value)
  
  
  For i = LBound(ar) To UBound(ar) - 1
    If buf = "" Then
      buf = Trim(ar(i))
    End If
    If ar(i) <> ar(i + 1) Then
      buf = buf & "," & ar2(i)
      j = j + 1
      ReDim Preserve art(j)
      flg = True
    Else
      buf = buf & "," & Trim(ar2(i))
    End If
    If flg Then
      k = Len(buf) - Len(Replace(buf, ",", ""))
      If mx < k Then
        mx = k
      End If
      art(j) = buf
      buf = ""
      flg = False
    End If
  Next i
  ReDim arb(mx, UBound(art))
  j = 0
  For i = LBound(art) To UBound(art)
    If Not IsEmpty(art(i)) Then
      For Each v In Split(art(i), ",")
        arb(j, i - 1) = v
        j = j + 1
      Next v
    End If
    j = 0
  Next i
  With sh2
    If k > 256 - Range(P).Row - 1 Then k = 256 - Range(P).Row - 1 'Ver.2003 まで
    sh1.Range(O).Resize(, 3).Copy .Range(P)
    .Range(P).Offset(, 2).Copy .Range(P).Offset(, 3).Resize(, k - 1)
    .Range(P).Offset(1, 1).Resize(UBound(arb, 2) + 1, k + 1).Value = _
    Application.Transpose(arb())
  End With

End Sub
    • good
    • 0
この回答へのお礼

無事に問題を解決することができました。
ありがとうございました。

お礼日時:2009/05/17 08:01

>見当もつきません。


表の体裁の組み換え(VBAで)は結構難しく中級以上の者の課題です。まだ早すぎる。だから丸投げになってしまうが、本質問コーナーに回答者にコードを書かせるのは規約違反です。下請け機関ではない。
ーー
本件には、ソート法が良かろう。
A1002の行を処理しているとき、次にA1000が出てきては困るからです。結果表を見れば判るとおり、
部品番号+ユニットの順に出てきてほしいのでその2列で昇順にソートする。同じ部品番号で同じユニットが複数出てくるのか質問に書いてないが、重要ポイントで、経験のなさを示している。無いとして、
Sheet2の列C、数字で言うと3からSheet1を1行読むごとにSheet2の列に順次ずらして書き出す。そのためには、書き出す列を示すポインター(変数)を持つ。Sheet1の1行読むごとに、ポインターを+1する。しかし
Sheet1で部品番号が変わったら、ポインターをC列数字で3にリセットする。
そのために直前の部品番号を記憶する変数を作り、次の行を呼んだとき毎回前行と比較して、変わったか判定する。
(A)部品番号が変わった
次行をさす。そして列はC列 に書く
(B)部品番号が変わらない
右隣列 に書く
==
ほかに
●Cells(i、j)の使い方知ってますか。
●最終行まで上記の処理を繰り返しますが、最終行の捉え方を知ってますか。
●現データと別の他シートへ結果表(Sheet2)書き出すを希望するなら
その表現法(コード)を知ってますか。
判らないなら、人のコードを盗めば何てこと無いものだが、判らないまま使うということになる。こういう本番のずっと前に、日ごろから後日に備え、他人の書いたコードを勉強して、頭に整理して無いと出来ないのです。
    • good
    • 0
この回答へのお礼

おっしゃる通りだと思います。
今回の教訓を糧に勉強に勤しみます。
ありがとうございました。

お礼日時:2009/05/17 08:04

提示された例題が、現状をありのままに表現されていればサンプルでも結果が得られるはずです。


もしかすると、A列に空白セルはなく、*以外のデータで埋まっているということでしょうか?
もし例題が仮定だとすると、実際に合わせて編集する必要があります。
編集できないのなら、実際の情報を現状に則して提供してみてください。
    • good
    • 0
この回答へのお礼

さっそくのご回答ありがとうございます。

実行結果ですが、先ほどは1行目のD列から・・・と
記述いたしましたが、2行目のD列からの間違いでした。
申し訳ございません。

実際のデータも例と同じく、
1行目のA列に"識別"、B列に"部品番号"、C列に"ユニット"と見出しがあり、
データは2行目から始まっています。
また、A列は空白セルか*しかありません。

先ほどご教授頂きましたプログラムの意味が理解できていないので、
どこが問題なのか全く把握できていないのが現状です。
自分で理解しようともせずに
xls88様にあまりにも丸投げしていましたので、
先ほどのプログラムの意味を調べる所から始めてみます。
ありがとうございました。

お礼日時:2009/05/16 18:01

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

QエクセルVBAでファイルを連続して処理する方法は

エクセルVBAで、エクセルファイルを開いた状態で特定処理を行う仕組みを作りました。
ただ、複数のファイルを処理したいのですが、いちいちファイルを開いてから処理しなければならないため効率が今ひとつです。
ファイル名称をテーブル化するなどして、一気に連続して処理するようにしたいのですが、どのように行えばいいでしょうか。

また、処理したいのは、更新日付が一定日以降のエクセルファイルです。
更新日付と対象ファイルのフォルダーを指定すれば、更新日がそれ以降のファイルを検索し、それが順次処理されていくようなVBAをつくりたいと考えています。

部分的にでもよいので、どなたか分かる方、教えてください。
ちなみにエクセルのバージョンは2000です。
よろしくお願いします。

Aベストアンサー

> 選択フォルダのサブフォルダをのものも含むようにはできないでしょうか。

再帰処理すればできますよ。

Microsoft Scripting Runtime を参照してから、次のコードを試してみて
下さい。
取り急ぎで書いたので、エラーがあるかもしれませんが。。。

まあ、環境によっては使えませんし、推奨はできないのですが、FileSearch
を使ってもサブフォルダを含めた検索はできます。調べればサンプルはすぐ
でてくると思いますよ。

ご参考までに。

Private mDateFilter As Date

Sub フォルダ内のXLSファイル順次処理()

  Dim fso As FileSystemObject
  Dim sDir As String
  
  ' // 日付のフィルタ条件設定 例)10日前の 0:00 以降更新のファイルを対象とする場合
  mDateFilter = DateAdd("d", -10, Date) + TimeValue("00:00:00")

  ' // 対象ファイルのあるフォルダを指定
  sDir = BrowseForFolder()
  If Len(sDir) = 0 Then
    Exit Sub
  End If

  Set fso = CreateObject("Scripting.FileSystemObject")
  
  Dim fld As Folder
  Dim iRes As Integer
  
  If fso.FolderExists(sDir) Then
    Set fld = fso.GetFolder(sDir)
    iRes = 0
    If fld.SubFolders.Count > 0 Then
      iRes = MsgBox("サブフォルダも検索しますか?", _
             vbYesNoCancel Or vbInformation)
    End If
    Select Case iRes
      Case vbYes:  Call FindFiles(fld, True)
      Case vbNo, 0: Call FindFiles(fld, False)
      Case Else:  ' // User Cancel
    End Select
  End If
  
  Set fld = Nothing
  Set fso = Nothing


End Sub

' // XLS ファイルを検索するサブプロシージャ
Private Sub FindFiles( _
  ByRef fld As Folder, _
  ByVal fCheckSubfolders As Boolean _
)

  ' // ファイルへの処理
  Dim f   As Object
  For Each f In fld.Files
    If f.Name Like "*.xls" And f.Name <> ThisWorkbook.Name Then
      If f.DateLastModified >= mDateFilter Then
        ' // 処理例
        Call MainProc(f)
      End If
    End If
  Next

  ' // サブフォルダ検索オプション
  Dim subFolder As folder
  If fCheckSubfolders Then
    ' // 再帰呼び出し
    For Each subFolder In fld.SubFolders
      Call FindFiles(subFolder, True)
    Next
  End If

End Sub

' // メイン処理 -- FindFiles から順次呼び出されます
Sub MainProc(ByRef f As file)

  ' // ここにご自分で書いたプロシージャを
  ' // とりあえず、セルにでも書き出してみます
  Dim i As Long
  i = Cells(Rows.Count, "A").End(xlUp).Row + 1
  Cells(i, "A").Value = f.Name
  Cells(i, "B").Value = f.DateLastModified

End Sub

' // フォルダ選択ダイアログ
Private Function BrowseForFolder() As String

  Const BIF_RETURNONLYFSDIRS = &H1

  Dim fld As Object
  Set fld = CreateObject("Shell.Application") _
       .BrowseForFolder(0&, "選択します", BIF_RETURNONLYFSDIRS)
  If Not fld Is Nothing Then
    BrowseForFolder = fld.Self.Path
  End If
  Set fld = Nothing

End Function

> 選択フォルダのサブフォルダをのものも含むようにはできないでしょうか。

再帰処理すればできますよ。

Microsoft Scripting Runtime を参照してから、次のコードを試してみて
下さい。
取り急ぎで書いたので、エラーがあるかもしれませんが。。。

まあ、環境によっては使えませんし、推奨はできないのですが、FileSearch
を使ってもサブフォルダを含めた検索はできます。調べればサンプルはすぐ
でてくると思いますよ。

ご参考までに。

Private mDateFilter As Date

Sub フォルダ内のXLS...続きを読む

QExcel2013 VBA A列とB列の文字をA列とB列とC列に移動させる方法

A列とB列に文字が入っているのですが、下記のようにA列とB列とC列に文字を移動させたいです。
(A列の数字は必ず奇数のA列に入っています。)
VBAのコードを教えて下さい。

例えば
A1 1  B1 cat
A2 空白 B2 猫
A3 空白 B3 dog
A4 空白 B4 犬
A5 2  B5 whale
A6 空白 B6 クジラ
A7 3  B7 rabbit
A8 空白 B8 ウサギ

とデータがある場合

A1 1  B1 cat  C1 猫
A2 空白 B2 dog  C2 犬
A3 2  B3 whale  C3 クジラ
A4 3  B4 rabbit C4 ウサギ

としたいです。

実際、データは、A5196まであります。

Aベストアンサー

No.1です。

>実際、データは、A5196まであります。

前回のコードは一つずつカット&ペーストしていますので
かなりの時間を要すると思います。
↓のコードに変更してみてください。

Sub Sample2()
Dim lastRow As Long
lastRow = Cells(Rows.Count, "B").End(xlUp).Row
Application.ScreenUpdating = False
With Range(Cells(1, "C"), Cells(lastRow, "C"))
.Formula = "=IF(MOD(ROW(),2)=1,B2,"""")"
.Value = .Value
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
Application.ScreenUpdating = True
MsgBox "完了"
End Sub

少しは短縮できると思います。m(_ _)m

No.1です。

>実際、データは、A5196まであります。

前回のコードは一つずつカット&ペーストしていますので
かなりの時間を要すると思います。
↓のコードに変更してみてください。

Sub Sample2()
Dim lastRow As Long
lastRow = Cells(Rows.Count, "B").End(xlUp).Row
Application.ScreenUpdating = False
With Range(Cells(1, "C"), Cells(lastRow, "C"))
.Formula = "=IF(MOD(ROW(),2)=1,B2,"""")"
.Value = .Value
.SpecialCells(xlCellTypeB...続きを読む

QエクセルVBA 2千万行のCSVファイルを開きたい

上から順に読み込み、順次処理していき最終的には全部処理します。CSVファイルは読むだけです。

やり方はいくつか考えられます。
1
100万行ずつシートに読み込み、終わったら次を読み込む。CSVファイルは開きっぱなし。

2
100万行ずつのエクセルファイルに分割し、順次開いて処理。ファイル開閉に時間がかかる

3
2千万行の巨大な配列に代入し、順次処理。
CSVファイルは閉じることが出来る。

3がいいように思えますが、どうでしょうか?使用メモリは1と同じですか?

Aベストアンサー

> 懸念点は、最初から最後まで巨大なCSVファイルを開いたまま処理することです。

それに関しては問題ないです。VBAのOpenでファイルを開いた場合、実は一切読んでいません。今何行目を読んでいるかを示すカウンタを用意するだけです。またLine Inputで読み込む場合も、今操作している一行しか相手にしません。

だからこそ、実装している物理メモリ量をはるかに超えるサイズのファイルを扱っていても、仮想メモリのお世話にならずに済むわけです。

なので懸念材料はそこではなく、分割処理することによってデータ同士の断絶が起きると言うか、連続性がなくなることでしょうか。最初の100万行の固まりと、次の100万個の固まりには全くつながりがないことになるので。

QA列とB列の重複を抽出したいのですがA列とB列の値は一部だけ同じ文字です。ご教示お願いします。

エクセル初心者です。重複を見つけるのが仕事です。いろいろやってみたのですがうまくできません。
お知恵をお貸しください。

A列には企業名が入力されています。
B列にも企業名が入力されていますが全く同じ文字ではないのです。

たとえばこういうことです。
A1 (有)雪見酒      B1  雪見
A2 株式会社豪雪地帯   B2 (株)豪雪地帯
A3 ゆきかき本舗     B3 (有)ゆきかき本舗

A列にある企業名とB列にある企業名が同じであればセルを塗りつぶすか○を表示させるように
したいのです。
重複を見つけるのが目的なので、ほかの方法でもかまいません。
すみません、A列のセルとB列のセルが全く同じ名前ならば重複が見つけられたのですが
ここから先がどうしてもわからないのです。。。
申し訳ありませんがどうか教えてください。。。

Aベストアンサー

No4です。以下のマクロを標準モジュールへ登録してください。
--------------------------------------------------
Option Explicit
Public Sub 重複チェック()
Dim maxrow1 As Long
Dim maxrow2 As Long
Dim row1 As Long
Dim row2 As Long
Dim nameT1() As String
Dim nameT2() As String
Dim t1, t2 As Variant
t1 = Time
maxrow1 = Cells(Rows.Count, "A").End(xlUp).row '最大行取得
maxrow2 = Cells(Rows.Count, "B").End(xlUp).row '最大行取得
ReDim nameT1(maxrow1)
ReDim nameT2(maxrow2)
Range("C1:" & "D" & maxrow2).Value = ""
Call makeTable(nameT1, "A", maxrow1)
Call makeTable(nameT2, "B", maxrow2)
For row1 = 1 To maxrow1
For row2 = 1 To maxrow2
If Cells(row2, "C") = "" Then
If Mymatch(nameT1(row1), nameT2(row2)) = True Then
Cells(row2, "C").Value = "○"
Cells(row2, "D").Value = row1
End If
End If
Next
Next
t2 = Time
MsgBox ("チェック完了 処理時間=" & Minute(t2 - t1) & "分" & Second(t2 - t1) & "秒")
End Sub
'余分な文字を削除した結果をテーブルに格納する
Private Sub makeTable(ByRef nameT() As String, ByVal col As String, ByVal maxrow As Long)
Dim row As Long
Dim ary As Variant
Dim name As String
Dim i As Long
ary = Array("㈱", "(株)", "株式", "(有)", "有限", "会社")
For row = 1 To maxrow
name = Cells(row, col).Value
For i = 0 To UBound(ary)
name = Replace(name, ary(i), "")
Next
nameT(row) = name
Next
End Sub
'企業名が一致かどうか判定する
Private Function Mymatch(ByVal name1 As String, ByVal name2 As String) As Boolean
Mymatch = False
Dim pos As Variant
pos = InStr(1, name1, name2, vbTextCompare)
If pos > 0 Then Mymatch = True
End Function
-----------------------------------------------------
一致の精度が悪ければその旨補足してください。
(一致すべきものが一致しない、一致してはいけないものが一致している)
100%解決できる保証はありませんが、多少のチューニングは行います。

No4です。以下のマクロを標準モジュールへ登録してください。
--------------------------------------------------
Option Explicit
Public Sub 重複チェック()
Dim maxrow1 As Long
Dim maxrow2 As Long
Dim row1 As Long
Dim row2 As Long
Dim nameT1() As String
Dim nameT2() As String
Dim t1, t2 As Variant
t1 = Time
maxrow1 = Cells(Rows.Count, "A").End(xlUp).row '最大行取得
maxrow2 = Cells(Rows.Count, "B").End(xlUp).row '最大行取得
ReDim ...続きを読む

QVBAからファイルをセル入力から開く方法

VBAからファイルをセル入力から開く方法

だれかご教授頂けませんでしょうか?VBAからエクセルファイルを開こうとしています。
そこでシート1のA1セルにファイル名を記述してあり、そのファイル名からファイルを開く事は出来ますでしょうか?
何か良い方法がありましたら教えて頂きたいのですが。

Aベストアンサー

下記で試してください。
パス名の最後には\を付けるようにしてください。

Workbooks.Open "D:\ABC\" & Sheets("シート1").Range("A1").Value


ワークシートのイベントを使う方法も考えられると思います。
BeforeDoubleClickイベント辺りを使って
ファイル名セルをダブルクリックすれば

Excel(エクセル) VBA入門:ワークシートのイベント
http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_event.html

Q【EXCEL】数式=SUM(A1*B1+A2*B2+・・・+A100*B100)を簡略化したい

お世話になります。

今Excelで、A1~A100とB1~B100まで数値が入っています。
セルC1に「=A1×b1」、C2に「=A2*B2」…C100に「=A100*B100」と入力しました。
そしてセルC101に「SUM(C1:C100)」と入力して合計を出しました。
(実際はもっと複雑な計算なのですが、説明の為に簡略化しています)

そうすると、計算結果セルが多く発生するためファイルサイズが莫大になってしまうのと、それを数千行×6列以上を一気に計算するとXPのリソースが足りないと出て計算できません。
なので2~3列ずつ何回も数式コピペを繰り返すことになっています。

そこで【別セルに掛け算をしてから全部SUMで足す】のではなく【1つのセルに掛け算とSUMを組み込む】という事を考えて
=SUM(A1*B1+A2*B2+・・・+A100*B100)を
を入力しようとしたのですが、数式が長すぎて四苦八苦です。

この式、なんとか簡略化できませんか?

Aベストアンサー

積の合計なら
=SUMPRODUCT(A1:A100,B1:B100)
でいいのでは?

QEXCEL VBA で現在開いているブックのファイル名を取得する方法

EXCEL2003 VBAで業務を簡素化するために、現在開いているブックのファイル名を取得する方法が分かりません。
作業手順をマクロを使って処理していますが、オリジナルのワークブックをファイル名を変えて保存し、以後、このワークブックを読み込んで使用しています。
このときのVBAは、オリジナルのファイル名を使っているため、ファイル名を変更するとエラーになり、以後の業務に使用できません。
常にファイル名を取得出来るVBAをどなたか、教えて下さい。

Aベストアンサー

>現在開いているブックのファイル名
 ちょっと曖昧な表現かなぁという気もいたしますが、VBAが書いてあるブックのブック名は
ThisWorkbook.Name
で、現在 "アクティブにして" 操作対象になっているブックの名前は
ActiveWorkbook.Name
ですね。

 しかし、
>VBAは、オリジナルのファイル名を使っているため、ファイル名を変更するとエラーになり
というような文脈からすると、
ThisWorkbook.Name
の方ですかね。

Q例えば、AさんからGさんまでがA列に縦に並んでいてB列に数字が入っています。B列にある数字の合計をA

例えば、AさんからGさんまでがA列に縦に並んでいてB列に数字が入っています。B列にある数字の合計をA-Gさん別々に出したいんですが簡単なvbaの記述方法はないでしょうか?
お願いします。

Aベストアンサー

こんばんは!

A列のA~Gさんは複数存在しているのでしょうか?
そうであればSUMIF関数で対応できると思いますが、VBAをお望みだというコトですので
一例です。

元データはSheet1にあり、Sheet2に表示するとします。
尚、Sheet1の1行目は項目行でデータは2行目以降にあるという前提です。
標準モジュールにしてください。

Sub Sample1()
Dim lastRow As Long, wS As Worksheet
Set wS = Worksheets("Sheet2")
wS.Cells.ClearContents
With Worksheets("Sheet1")
.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS.Range("A1"), unique:=True
lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
With Range(wS.Cells(2, "B"), wS.Cells(lastRow, "B"))
.Formula = "=SUMIF(Sheet1!A:A,A2,Sheet1!B:B)"
.Value = .Value
End With
End With
End Sub

こんな感じではどうでしょうか?m(_ _)m

こんばんは!

A列のA~Gさんは複数存在しているのでしょうか?
そうであればSUMIF関数で対応できると思いますが、VBAをお望みだというコトですので
一例です。

元データはSheet1にあり、Sheet2に表示するとします。
尚、Sheet1の1行目は項目行でデータは2行目以降にあるという前提です。
標準モジュールにしてください。

Sub Sample1()
Dim lastRow As Long, wS As Worksheet
Set wS = Worksheets("Sheet2")
wS.Cells.ClearContents
With Worksheets("Sheet1")
.Range("A:A...続きを読む

Q他のExcelファイルのVBAコードを検索したい

他のExcelファイルに書かれたVBAコードに、ある特定のキーワード(パス名など)が使われているかを自動的に調べるためのVBAを書きたいと思っています。

仕事で使っているマクロが書かれたExcelファイルからある特定の処理をしているマクロを含むものを検索したいのですが、検索するExcelファイルが膨大なため、順番にExcelファイルを開いてVBAコードをチェックしていく工程をマクロ化したいのです。ファイルを順に開いていく処理はマクロ化できるのですが、書かれたVBAコードのチェックをどうしたらよいか悩んでいます。

「VBAコードに対して検索する」または「VBAコードを1行ずつ変数に代入する」、「モジュールシートをテキストファイルに出力する」などの処理が自動化できれば対応できそうなのですが、そのような処理をExcelVBAで作成できるでしょうか。

なお環境はWindowsXPのExcel2003です。
よろしくお願いいたします。

Aベストアンサー

開いたブックにあるVBAコードをテキストに出力する方法
Sub VBExport(WKB As Workbook)
  Dim A, B
  Set A = WKB.VBProject.VBComponents
  For Each B In A
    B.Export "C:\~" '★テキストファイルでエクスポート
    xxxxxx '★上記テキストファイルを調べる処理
  Next
End Sub
ブックやシートにあるコードも(空でも)出力されます。
もし、標準モジュールのみ処理したい場合は「B.Type = 1」に限り
エクスポートします。

QエクセルでB列の数値がA列(A1:A10)の範囲に存在するかどうかを知りたい

こんばんは。
エクセルでこのようなことができるのかどうか分からないので、教えてください。

B列の数値がA列(A1:A10)の範囲に含まれる数値なら○、含まれない数値なら×と、C列に表示したいのですが、エクセルでそのようなことはできるのでしょうか。
できるのであれば方法を教えていただけますでしょうか。
よろしくお願いいたします。

<<最終的な結果は以下のように表示したいです>>

  A B C

1 12 19 ○

2 15 20 ○

3 19 28 ○

4 20 30 ×

5 23 34 ○

6 28 35 ×

7 32 38 ×

8 34 39 ○

9 39

10 40

Aベストアンサー

セル C1 に式 =IF(COUNTIF(A:A,B1),"○","×") を入力して、此れを下方にズズーッと複写


人気Q&Aランキング

おすすめ情報