Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


12162 / 13644 ツリー ←次へ | 前へ→

【11927】別シートに必要なデータだけ貼り付けたい かを 04/3/18(木) 18:38 質問
【11930】Re:別シートに必要なデータだけ貼り付けたい IROC 04/3/18(木) 18:47 回答
【11931】Re:別シートに必要なデータだけ貼り付けたい かを 04/3/18(木) 19:00 発言
【11933】Re:別シートに必要なデータだけ貼り付けたい IROC 04/3/18(木) 20:48 回答
【11947】Re:別シートに必要なデータだけ貼り付けたい かを 04/3/19(金) 9:24 発言
【11948】Re:別シートに必要なデータだけ貼り付けたい Asaki 04/3/19(金) 9:45 回答
【11950】Re:別シートに必要なデータだけ貼り付けたい IROC 04/3/19(金) 10:09 回答
【11953】Re:別シートに必要なデータだけ貼り付けたい かを 04/3/19(金) 10:54 発言
【11955】Re:別シートに必要なデータだけ貼り付けたい IROC 04/3/19(金) 11:11 回答
【11963】Re:別シートに必要なデータだけ貼り付けたい かを 04/3/19(金) 14:21 発言
【11965】Re:別シートに必要なデータだけ貼り付けたい Asaki 04/3/19(金) 15:00 回答
【11968】Re:別シートに必要なデータだけ貼り付けたい かを 04/3/19(金) 15:58 発言
【11969】Re:別シートに必要なデータだけ貼り付けたい Asaki 04/3/19(金) 16:25 回答
【11974】Re:別シートに必要なデータだけ貼り付けたい かを 04/3/19(金) 19:11 発言
【11982】Re:別シートに必要なデータだけ貼り付けたい Asaki 04/3/20(土) 14:47 回答
【11998】Re:別シートに必要なデータだけ貼り付けたい かを 04/3/21(日) 11:58 発言
【12000】Re:別シートに必要なデータだけ貼り付けたい Asaki 04/3/21(日) 16:40 回答
【11999】Re:別シートに必要なデータだけ貼り付けたい Hirofumi 04/3/21(日) 14:18 回答
【12011】Re:別シートに必要なデータだけ貼り付けたい かを 04/3/22(月) 10:23 お礼

【11927】別シートに必要なデータだけ貼り付けたい
質問  かを  - 04/3/18(木) 18:38 -

引用なし
パスワード
   次のような社員のデータを

番号 名前 身長 体重
01  太郎  170  60 
02  花子  160  40
03  次郎  165  65
04  智子  150  40

下記のようなあらかじめ作ってある別シートに、番号をキーにして、必要な人の、必要な項目を順番を入れ替えて貼り付けたいのですが

番号 体重 名前
02  
04 

シンプルにかつ高度にやる方法を教えていただけませんでしょうか?
宜しくお願いします。 

【11930】Re:別シートに必要なデータだけ貼り付け...
回答  IROC  - 04/3/18(木) 18:47 -

引用なし
パスワード
   番号 01 , 02 ・・・は文字列ですか?

セルに入力されている値と、表示形式を教えて下さい。

【11931】Re:別シートに必要なデータだけ貼り付け...
発言  かを  - 04/3/18(木) 19:00 -

引用なし
パスワード
   ▼IROC さん:
>番号 01 , 02 ・・・は文字列ですか?
>
>セルに入力されている値と、表示形式を教えて下さい。

すべて数値型でお願いします。(名前は例えただけなので)
宜しくお願いします。

【11933】Re:別シートに必要なデータだけ貼り付け...
回答  IROC  - 04/3/18(木) 20:48 -

引用なし
パスワード
   A列は数値だと 01 → 1  になると思いますが?

表示形式のユーザー定義で 00 にしてあるのでしょうか?

正確にご説明して頂かないと、回答できません。

【11947】Re:別シートに必要なデータだけ貼り付け...
発言  かを  - 04/3/19(金) 9:24 -

引用なし
パスワード
   ▼IROC さん:
>A列は数値だと 01 → 1  になると思いますが?
>
>表示形式のユーザー定義で 00 にしてあるのでしょうか?
>
>正確にご説明して頂かないと、回答できません。
すみません、数値型でお願いします。
申し訳ございません。

【11948】Re:別シートに必要なデータだけ貼り付け...
回答  Asaki  - 04/3/19(金) 9:45 -

引用なし
パスワード
   こんにちは。
後ろから失礼します。

フィルタオプションじゃダメなんでしょうか?

【11950】Re:別シートに必要なデータだけ貼り付け...
回答  IROC  - 04/3/19(金) 10:09 -

引用なし
パスワード
   VBAを使わなくても

Sheet2 に抽出するとして、
B2に
=VLOOKUP(A2,Sheet1!A2:D10,2,FALSE)
として、行方向にコピー

C2に
=VLOOKUP(A2,Sheet1!A2:D10,3,FALSE)
として、行方向にコピー
 
D2に
=VLOOKUP(A2,Sheet1!A2:D10,4,FALSE)
として、行方向にコピー

で出来ませんか?

【11953】Re:別シートに必要なデータだけ貼り付け...
発言  かを  - 04/3/19(金) 10:54 -

引用なし
パスワード
   ▼IROC さん:
>VBAを使わなくても
>
>Sheet2 に抽出するとして、
> B2に
>=VLOOKUP(A2,Sheet1!A2:D10,2,FALSE)
>として、行方向にコピー
>
> C2に
>=VLOOKUP(A2,Sheet1!A2:D10,3,FALSE)
>として、行方向にコピー
> 
> D2に
>=VLOOKUP(A2,Sheet1!A2:D10,4,FALSE)
>として、行方向にコピー
>
>で出来ませんか?

返信ありがとうございます。
すみません、別シートにコピーと書きましたが、元からある別ブックに書き出しのような事をしたいのです。別ブックには一ヶ月分のシートが(30シート)あります。元データは、カンマ区切りのテキストファイルです。セルのコピーなどの記述で出来る事は出来るのですが、シンプルに行いたいのです。配列と言うのは別なのでしょうか?勉強不足ですみません。

【11955】Re:別シートに必要なデータだけ貼り付け...
回答  IROC  - 04/3/19(金) 11:11 -

引用なし
パスワード
   社員のデータ=元データで、
これは、Excel(.xls) でなく、CSVファイルなのですか?

マクロを書くブックは、「一ヶ月分のシートが(30シート)」のブックですか?

ファイル名やシート名を詳しく教えて下さい。

【11963】Re:別シートに必要なデータだけ貼り付け...
発言  かを  - 04/3/19(金) 14:21 -

引用なし
パスワード
   ▼IROC さん:
>社員のデータ=元データで、
>これは、Excel(.xls) でなく、CSVファイルなのですか?
>
>マクロを書くブックは、「一ヶ月分のシートが(30シート)」のブックですか?
>
>ファイル名やシート名を詳しく教えて下さい。
マクロを書くのは全く別のブックのフォームから行おうとしていました。
社員のデータ=元データで、csvファイルです。一ヶ月分のシートの方は既に表のような物が出来ていて、必要のない人は省いてコピーしたいのです。
NO  A  B   C
1  12  13  25
2   5  60  20
3   4   8   7

のようなデータを
NO  C   A
1  25  12
3   7   4
↑別ブックにあらかじめNOの1と3が入っていて、その人のデータだけCAの順に並べ替えて貼り付けたいのです。
配列と言うのはこの場合関係ないのですか?

【11965】Re:別シートに必要なデータだけ貼り付け...
回答  Asaki  - 04/3/19(金) 15:00 -

引用なし
パスワード
   取り敢えず、データの入ったcsvファイルは開くのですよね?

まずは、あるNoのデータをコピーする方法を考えることにして、
マクロの記録で、あるデータを検索する処理をお試しください。

>配列と言うのはこの場合関係ないのですか?
多分、関係ないと思います。

【11968】Re:別シートに必要なデータだけ貼り付け...
発言  かを  - 04/3/19(金) 15:58 -

引用なし
パスワード
   ▼Asaki さん:
>取り敢えず、データの入ったcsvファイルは開くのですよね?
>
>まずは、あるNoのデータをコピーする方法を考えることにして、
>マクロの記録で、あるデータを検索する処理をお試しください。
>
>>配列と言うのはこの場合関係ないのですか?
>多分、関係ないと思います。
検索した後はどのようにすればいいのでしょう。

【11969】Re:別シートに必要なデータだけ貼り付け...
回答  Asaki  - 04/3/19(金) 16:25 -

引用なし
パスワード
   >検索した後はどのようにすればいいのでしょう。
検索で合致する値が見つかった場合は、同じ行のCとAを、結果を表示したいシートに貼り付けます。
検索から、コピーして貼付までの操作を、抽出したいNo全てに対して行うようにループ処理をします。
雰囲気的には、↓のような感じで。
尚、とりあえずは、検索元と抽出先は同じブックの別のシートということにします。
抽出先のシート名が Sheet2 と仮定しています。

Sub sample()

  Dim rng     As Range
  Dim sh     As Worksheet

  Set sh = Worksheets("Sheet2")
  For Each rng In sh.Range("A2", sh.Cells(65536, 1).End(xlUp))
    '検索:検索値は rng.Value を指定
    '値の貼り付け
  Next rng

  Set sh = Nothing
End Sub

【11974】Re:別シートに必要なデータだけ貼り付け...
発言  かを  - 04/3/19(金) 19:11 -

引用なし
パスワード
   ▼Asaki さん
すみません、この場合だと、並べ替えたりするのは、どの部分になるのでしょうか?

【11982】Re:別シートに必要なデータだけ貼り付け...
回答  Asaki  - 04/3/20(土) 14:47 -

引用なし
パスワード
   >並べ替えたりするのは、どの部分になるのでしょうか?
並べ替える、というのは、CとAの位置関係を変えることでしょうか?

取り敢えず、検索を実行すると、コピーしたいデータがどの行か解りますね?
その行のCおよびAを、新しいシートに書き込むことになります。

検索すると結果はRange型で返ってくるので、これをrngFindと表すと、
CはNoの列の3つ右隣なので
rngFind.Offset(,3)
同じようにAは
rngFind.Offset(,1)
と表せます。
これらを、それぞれ
rng.Offset(,1) , rng.Offset(,2)
に貼り付けます。

【11998】Re:別シートに必要なデータだけ貼り付け...
発言  かを  - 04/3/21(日) 11:58 -

引用なし
パスワード
   ▼Asaki さん:
ありがとうございます。
もし検索に該当したデータが50人分あるとしても一回の記述で済むのでしょうか?

【11999】Re:別シートに必要なデータだけ貼り付け...
回答  Hirofumi E-MAIL  - 04/3/21(日) 14:18 -

引用なし
パスワード
   社員のデータはCsvファイルで、以下の様に成っていると想定します

1,12,13,25
2,5,60,20
3,4,8,7

出力する、シートは、以下の様に成っていると想定します

NO  C   A
1
3

NOは、1行目A列に有る物とします

このコードでは、社員のデータのCsvファイルをBookに展開せず
Openステートメントを使って1行づつ読み込み、
ActiveWorkbookのActiveSheetのNoを探して書きこんで行きます
Dictionary オブジェクトが使える環境なら、簡単なコードでは有りませんが
Findで探すより幾らか早いと思います

以下を標準モジュールに記述して下さい

Option Explicit

Public Sub DataExtraction()

  Dim i As Long
  Dim j As Long
  Dim dfn As Integer
  Dim vntFileName As Variant
  Dim strBuff As String
  Dim vntField As Variant
  Dim wksResult As Worksheet
  Dim vntResult As Variant
  Dim lngWrite As Long
  Dim lngEnd As Long
  Dim dicIndex As Object
  
  '結果書き込みシートの参照を設定
  Set wksResult = ActiveWorkbook.ActiveSheet
  '書き込み行の初期値を設定
  lngWrite = 2
  
  '社員データのファイル名を取得
  If Not GetReadFile(vntFileName, _
          ThisWorkbook.Path, False) Then
    GoTo ExitHandler
  End If
  
  With wksResult
    '探索範囲(No)の有る最終行取得
    lngEnd = .Cells(65536, "A").End(xlUp).Row
    '探索範囲(No)が無い場合
    If lngEnd < lngWrite Then
      Beep
      MsgBox "データが有りません"
      GoTo ExitHandler
    End If
    '探索範囲(No)の値を配列に取得
    vntResult = Range(.Cells(lngWrite, "A"), _
              .Cells(lngEnd, "B")).Value
  End With
    
  'Dictionary オブジェクトのインスタンスを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")
  
  '社員データのファイルをOpen
  dfn = FreeFile
  Open vntFileName For Input As dfn

  'Dictionaryに就いて
  With dicIndex
    For i = 1 To UBound(vntResult, 1)
      '探索範囲(No)の値をdicIndexにセット、
      .Add CLng(vntResult(i, 1)), i
      '及び結果用配列を初期化
      For j = 1 To 2
        vntResult(i, j) = Empty
      Next j
    Next i
    Do Until EOF(dfn)
      '社員データから1行読み込み
      Line Input #dfn, strBuff
      '読み込んだレコードをフィールドに分割
      vntField = SplitCsv(strBuff, ",")
      'Dictionaryに有った場合
      If .Exists(CLng(vntField(0))) Then
        i = .Item(CLng(vntField(0)))
        '結果用配列に列を入れ替えて代入
        vntResult(i, 1) = vntField(3)
        vntResult(i, 2) = vntField(1)
      End If
    Loop
  End With
  
  '社員データのファイルをClose
  Close #dfn
  
  '結果を結果用シートに出力
  With wksResult
    .Cells(lngWrite, _
        "B").Resize(UBound(vntResult, 1), 2) _
                      = vntResult
  End With
  
  Beep
  MsgBox "処理が終了しました"
  
ExitHandler:
    
  Set wksResult = Nothing
  Set dicIndex = Nothing
  
End Sub

Private Function SplitCsv(ByVal strLine As String, _
            Optional strDelimiter As String = ",", _
            Optional strQuote As String = """", _
            Optional strRet As String = vbCrLf, _
            Optional blnMulti As Boolean) As Variant

' Csvレコード分割関数

'      strLine     :分割元と成る文字列
'      strDelimiter  :区切り文字
'      SplitCsv    :戻り値、切り出された文字配列

  Dim lngDPos As Long
  Dim vntData() As Variant
  Dim lngStart As Long
  Dim i As Long
  Dim vntField As String
  Dim lngLength As Long
  
  i = 0
  lngStart = 1
  lngLength = Len(strLine)
  blnMulti = False
  Do
    ReDim Preserve vntData(i)
    If Mid$(strLine, lngStart, 1) <> strQuote Then
      lngDPos = InStr(lngStart, strLine, _
            strDelimiter, vbBinaryCompare)
      If lngDPos > 0 Then
        vntField = Mid$(strLine, lngStart, _
                  lngDPos - lngStart)
        lngStart = lngDPos + 1
      Else
        vntField = Mid$(strLine, lngStart)
        lngStart = lngLength + 1
      End If
    Else
      lngStart = lngStart + 1
      Do
        lngDPos = InStr(lngStart, strLine, _
                strQuote, vbBinaryCompare)
        If lngDPos > 0 Then
          vntField = vntField & Mid$(strLine, _
                lngStart, lngDPos - lngStart)
          lngStart = lngDPos + 1
          Select Case Mid$(strLine, lngStart, 1)
            Case ""
              Exit Do
            Case strDelimiter
              lngStart = lngStart + 1
              Exit Do
            Case strQuote
              lngStart = lngStart + 1
              vntField = vntField & strQuote
          End Select
        Else
          blnMulti = True
          vntField = Mid$(strLine, lngStart) & strRet
          lngStart = lngLength + 1
          Exit Do
        End If
      Loop
    End If
    vntData(i) = vntField
    vntField = ""
    i = i + 1
  Loop Until lngLength < lngStart
  
  SplitCsv = vntData()
  
End Function

Private Function GetReadFile(vntFileNames As Variant, _
            Optional strFilePath As String, _
            Optional blnMultiSel As Boolean _
                    = False) As Boolean

'  ファイル名取得関数

  Dim strFilter As String
  
  'フィルタ文字列を作成
  strFilter = "CSV File (*.csv),*.csv," _
        & "Text File (*.txt),*.txt," _
        & "CSV and Text (*.csv; *.txt),*.csv;*.txt," _
        & "全て (*.*),*.*"
  '読み込むファイルの有るフォルダを指定
  If strFilePath <> "" Then
    'ファイルを開くダイアログ表示ホルダに移動
    ChDrive Left(strFilePath, 1)
    ChDir strFilePath
  End If
  'もし、ディフォルトのファイル名が有る場合
  If vntFileNames <> "" Then
    SendKeys vntFileNames, False
  End If
  '「ファイルを開く」ダイアログを表示
  vntFileNames _
      = Application.GetOpenFilename(strFilter, 1, , , blnMultiSel)
  If VarType(vntFileNames) = vbBoolean Then
    Exit Function
  End If
  
  GetReadFile = True
  
End Function

【12000】Re:別シートに必要なデータだけ貼り付け...
回答  Asaki  - 04/3/21(日) 16:40 -

引用なし
パスワード
   >もし検索に該当したデータが50人分あるとしても一回の記述で済むのでしょうか?
検索の部分をループ処理に変更すればよいです。
(書き込み位置の指定は、別途考える必要がありますが)

または、csvファイルの方をNoでソートしてから処理するほうが簡単かもしれません。

【12011】Re:別シートに必要なデータだけ貼り付け...
お礼  かを  - 04/3/22(月) 10:23 -

引用なし
パスワード
   ▼Hirofumi さん:
本当にありがとうございます。ちょっと時間がかかりそうですけどチャレンジしてみます。お手数かけました。

12162 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free