以下、ご教示ください。
マクロ及びVBA初心者のため、何卒お願い致します。

まず、sheet1に毎日更新されるデータをダウンロードして貼り付けます。
具体的には株式市場に上場している全銘柄の株価です。(ここでは上段の画像となります)
この作業は毎日行うものです。

次にsheet2にすでにとある銘柄の過去の日々の株価データが蓄積されているのですが、
(ここでは下段の画像で、銘柄1376を例で記載しております。)
記載がある最後の行の次の行から、sheet1から1376を検索して、
名称や日時、株価の貼付けを実行することを自動化したいと考えております。

つまり、sheet1に全銘柄のデータを貼り付けたら、
sheet2の最後の行の次の行に最新の1376のデータが反映されるようにしたいのです。

(今回はsheet2だけで質問しておりますが、sheet30くらいまであるため)

worksheetFunction.Vlookupや
n=cell(Rows.count,"B").End(xlup).Row+1

このあたりを使用するのではと検討はついたのですが、
その先が詰まりました。

サンプルコードなどご教示いただきたくお願い致します。

「エクセルマクロ、VBAについて」の質問画像

A 回答 (4件)

No.1よりスマートに。



Sub WK()
Dim CNT As Long
Dim END1 As Long
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet

Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")
END1 = Sh1.Range("A65536").End(xlUp).Row
END2 = Sh2.Range("A65536").End(xlUp).Row

Set 行 = Sh1.Range("A2:A" & END1).Find("1376")

If 行 Is Nothing Then
Else
Sh2.Range("A" & END2 + 1).Value = 1376
Sh2.Range("B" & END2 + 1).Value = Sh1.Range("B" & 行).Value
Sh2.Range("C" & END2 + 1).Value = Sh1.Range("C" & 行).Value
Sh2.Range("D" & END2 + 1).Value = Sh1.Range("D" & 行).Value

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

助かりました

ありがとうございます。
今出先のため、pc触れる環境になりましたら、挑戦させて頂きます!

お礼日時:2017/05/15 09:44

ANo3です



1列目が数字として入力されているかもしれませんでしたね。

安全側の判断とするため、3行目の宣言文を訂正しておきます。
(訂正前)Dim rw As Long, index As Long, id As String
 ↓↓↓
(訂正後)Dim rw As Long, index As Long, id
    • good
    • 0
この回答へのお礼

ありがとうございます。
勉強になります。
まだまだ難しいですが、試行錯誤しながら勉強します。

お礼日時:2017/05/16 06:42

勝手に想定してますが・・・



Sub Sample()
Dim sh As Worksheet, tbl As Range
Dim rw As Long, index As Long, id As String

Set tbl = Worksheets("Sheet1").Range("A:A")
Set tbl = tbl.Cells(1, 1).Resize(tbl.Cells(Rows.Count, 1).End(xlUp).Row, 3)

For Each sh In Worksheets
 id = sh.Cells(2, 1).Value
 If sh.Name <> "Sheet1" And id <> "" Then
  index = 0
  On Error Resume Next
  index = WorksheetFunction.Match(id, tbl.Columns(1), 0)
  On Error GoTo 0

  If index > 1 Then
   rw = sh.Cells(Rows.Count, 1).End(xlUp).Row
   If sh.Cells(rw, 3).Value < tbl.Cells(index, 3).Value Then
    tbl.Rows(index).EntireRow.Copy Destination:=sh.Rows(rw + 1)
   End If
  End If
 End If
Next sh

End Sub
    • good
    • 0

Sub WK()


Dim Sh1 As Worksheet
Dim Sh2 As Worksheet

Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")
END1 = Sh1.Range("A65536").End(xlUp).Row
END2 = Sh2.Range("A65536").End(xlUp).Row

Sh2.Range("A" & END2 + 1).Value = 1376

Sh2.Range("B" & END2 + 1).Value = Application.WorksheetFunction.VLookup(Sh2.Range("A" & END2 + 1).Value, Sh1.Range("A2:D" & END1 + 1).Value, 2, False)

 Sh2.Range("C" & END2 + 1).Value = Application.WorksheetFunction.VLookup(Sh2.Range("A" & END2 + 1).Value, Sh1.Range("A2:D" & END1 + 1).Value, 3, False)

Sh2.Range("D" & END2 + 1).Value = Application.WorksheetFunction.VLookup(Sh2.Range("A" & END2 + 1).Value, Sh1.Range("A2:D" & END1 + 1).Value, 4, False)

End Sub
    • good
    • 0

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

このQ&Aを見た人はこんなQ&Aも見ています

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

Qマクロ 検索した条件に対応する値を選択したセルに貼り付ける マクロでsheet1のBの名前をshe

マクロ 検索した条件に対応する値を選択したセルに貼り付ける

マクロでsheet1のBの名前をsheet2のA列から検索してsheet2のF列をsheet1で選択したセルへ貼り付けたいです。
良い方法はないでしょうか?(٭°̧̧̧ω°̧̧̧٭)
助けてください!!

Aベストアンサー

ここの掲示板で常連のある方の回答なら、ある程度決まったパターンで回答します。

単なる想像ですが、もしかしたら、質問の要素の肝心な説明が抜けていませんか?

これは、私の回答者としての想像ですが、抜けているのは、
「上の画像は、月次報告のデータ」
「下の画像は、年次データリスト」

この年次リストの月次報告データのそれぞれのスタッフのデータを年次データ・リストに転記する
(回答者としても、10数年も経理や総務で、表を作ってきた人間もいますから、なんとなくわかるものはわかります。)

>マクロでsheet1のBの名前をsheet2のA列から検索してsheet2のF列をsheet1で選
>択したセルへ貼り付けたいです。

この文章そのものは、Sheet1 もSheet2 も間違っていないのではありませんか?画像の表示が間違えたということだと思うのです。

本来順序が同じなら、そのままコピー&ペーストで行けるはずですが、そうとはなっていないのでしょう。やめた社員などあると順序が狂うわけですね。

コードは汚いのですが、一応、考えてみました。

'//
Sub FilledNumbers()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim cls As Long, cld As Long 'cls=ソース側, cld =目的側 destine
Dim i As Variant, j As Long
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")

With sh1
 Set rng1 = .Range("B1", .Cells(Rows.Count, 2).End(xlUp))
 'データ1行目からのほうが特定しやすい、B列名前欄
 cls = .Cells(1, Columns.Count).End(xlToLeft).Column
 'Sheet1 の最後の列を探している
 cls = cls - 1 '名前欄が、2列目だから、1列減る
End With
With sh2
 Set rng2 = .Range("A1", .Cells(Rows.Count, 1).End(xlUp))
 cld = .Cells(1, Columns.Count).End(xlToLeft).Column
 '月次だから、月によって変わる。必ず7月なら7月というタイトルが必要
 If cld < 2 Then cld = 2  '使うことはないはず
End With

For j = 2 To rng1.Rows.Count
If rng1.Cells(j, cls).Value <> "" Then
  i = Application.Match(rng1.Cells(j, 1).Value, rng2, False)
  If IsNumeric(i) Then
   rng2.Cells(i, cld).Value = rng1.Cells(j, cls).Value
  Else
   rng1.Cells(j, cls).Offset(, 1).Value = "x"
   '見つからなかった場合に x をつける
  End If
End If
Next
End Sub

ここの掲示板で常連のある方の回答なら、ある程度決まったパターンで回答します。

単なる想像ですが、もしかしたら、質問の要素の肝心な説明が抜けていませんか?

これは、私の回答者としての想像ですが、抜けているのは、
「上の画像は、月次報告のデータ」
「下の画像は、年次データリスト」

この年次リストの月次報告データのそれぞれのスタッフのデータを年次データ・リストに転記する
(回答者としても、10数年も経理や総務で、表を作ってきた人間もいますから、なんとなくわかるものはわかります。)

>マ...続きを読む

Qエクセルで書式のコピー貼り付けを行うと貼り付けられた部分の書式が変更さ

エクセルで書式のコピー貼り付けを行うと貼り付けられた部分の書式が変更されてしまうため、コピーと貼り付けができないようにするため、ネットで調べてコードを試していました。(結局実力がないためできませんでした。)あとで気がついたのですが、シート上でショートカットメニューを使ってコピー貼り付けを行ってみたら、その中の貼り付けのアイコンと文字だけが薄くなっていて貼り付けができない状態になっていました。エクセルの他の場所にある貼り付けアイコンやショートカットキー(Ctr+V)等では正常に行えます。ショートカットメニュー内の貼り付けはどんなコードを実行すれば有効にして回復させることができるのでしょうか。よろしくお願いいたします。(エクセル2007を使用です。)

Aベストアンサー

>ショートカットメニュー内の貼り付けはどんなコードを実行すれば有効にして回復させることができるのでしょうか。
他にショートカットメニューをカスタマイズしてなければ、CommandBarごとリセットするのが簡単です。
Sub test()
  Dim cb As CommandBar
  
  For Each cb In Application.CommandBars
    Select Case cb.Name
    Case "Cell", "Row", "Column"
      cb.Reset
    End Select
  Next
End Sub

Qヤフーファイナンス 株価時系列データ EXCEL VBA データ取り込み 

ヤフーファイナンスの株価時系列データを、EXCELのVBAを使って、1回のマクロ操作で複数銘柄EXCELに取り込みたいと考えています。

EXCEL Sheet1のA1、A2、A3、、、に取り込みたい銘柄コードを記入し、マクロを走らせると同ブック内で銘柄コード別にシートが出来上がるのが理想です。

データ取得期間は”デイリー”で”1999/1/1~2012/1/1”を考えています。

よろしくお願いします。

Aベストアンサー

>(私は、今回そこまでやるつもりはないですが)
...と書いておきながらやるワタシって...orz

Option Explicit
Sub test()
  Dim fromDate As Date '取得開始日
  Dim toDate  As Date '取得終了日
  Dim n    As Long
  Dim d, cds()

  'Dim t As Single
  't = Timer
  'toDateに取得終了日をセット可能
  toDate = Date '#8/31/2009#
  With Sheets("Sheet1")
    'B1セルから前回取得終了日をセット。最初は未入力で可
    d = .Range("B1").Value
    If IsDate(d) Then
      If d >= toDate Then Exit Sub
      fromDate = CDate(d + 1)
    End If
    'B1未入力だったら1999.1.1
    If fromDate < #1/1/1999# Then
      fromDate = #1/1/1999#
    End If
    '銘柄コードを配列で取得
    n = .Cells(.Rows.Count, 1).End(xlUp).Row
    If n = 1 Then
      ReDim cds(0)
      cds(0) = .Range("A1").Value
    Else
      cds() = .Range("A1").Resize(n).Value
    End If
    '引数:銘柄配列, 開始日, 終了日
    Call getXML(cds(), fromDate, toDate)
    'B1セルに今回取得終了日
    .Range("B1").Value = toDate
  End With
  'Debug.Print Timer - t
End Sub
'---------------------------------------------------------------------
Sub getXML(ByRef cds() As Variant, _
      ByVal dCHK As Date, _
      ByVal dDate As Date)
  Const FLD = "日付 始値 高値 安値 終値 出来高 調整後終値*" '列項目名
  Const CX As Long = 7                   '配列の列数(項目数)
  Const PTN = ">([^<>\n]+)<"                'データ抜き出しパターン
  Const CHK = "<small>調整後終値*</small></th>"       'テーブル判断項目htmlTEXT
  Dim dTMP As Date   '検索開始Date
  Dim xh  As Object  'MSXML2.ServerXMLHTTP
  Dim re  As Object  'VBScript.RegExp
  Dim mc  As Object  'RegExp.Match
  Dim ws  As Worksheet 'データ書き出しSheet
  Dim flg As Boolean  'LoopOut判定FLG
  Dim url As String  'URLアドレス
  Dim ret As String  'XMLHTTP.responsetext
  Dim s(7) As String  'URL構成文字列
  Dim dX  As Long   '期間日数
  Dim n  As Long   'chk文字存在判定
  Dim x  As Long   'HTML項目Loop用
  Dim cnt As Long   'データCOUNT
  Dim i  As Long
  Dim j  As Long
  Dim k  As Long
  Dim v, w       'データ格納用配列,列項目名分割用配列
  Dim cd        '銘柄Loop用

  On Error Resume Next
  Set xh = CreateObject("MSXML2.ServerXMLHTTP")
  On Error GoTo 0
  If xh Is Nothing Then Exit Sub
  
  On Error GoTo errHndlr

  '開始日より1ページ多目に
  dTMP = DateAdd("d", -50, dCHK)
  s(1) = "c=" & Year(dTMP) '開始年
  s(2) = "a=" & Month(dTMP)  '開始月
  s(3) = "b=" & Day(dTMP)  '開始日
  s(4) = "f=" & Year(dDate) '現在年
  s(5) = "d=" & Month(dDate)  '現在月
  s(6) = "e=" & Day(dDate)  '現在日
  s(7) = "g=d&q=t&y="

  dX = CLng(dDate - dCHK) + 1
  '期間日数から配列の大きさを設定(+1がちょっと肝)
  ReDim v(1 To dX + 1, 1 To CX)
  w = Split(FLD)

  Set re = CreateObject("VBScript.RegExp")
  re.Pattern = PTN
  re.Global = True
  
  'コード範囲をLoop
  For Each cd In cds
    s(0) = "http://table.yahoo.co.jp/t?s=" & cd
    url = Join(s, "&")
    cnt = 1
    For i = 0 To dX Step 50
      xh.Open "GET", url & i, False
      xh.Send
      If (xh.Status >= 200) And (xh.Status < 300) Then
        ret = xh.responsetext
        n = InStr(ret, CHK)
        If n = 0 Then Exit For
        ret = Mid$(ret, n + Len(CHK))
        Set mc = re.Execute(ret)
        x = 0
        For j = 1 + i To 50 + i
          cnt = j
          For k = 1 To CX
            v(j, k) = mc(x).submatches(0)
            'データ終了判定
            If k = 1 Then
              flg = IsDate(v(j, 1))
              If flg Then
                v(j, 1) = CDate(v(j, 1))
                flg = (v(j, 1) >= dCHK)
              End If
              If Not flg Then
                j = i + 50
                i = dX
                Exit For
              End If
            End If
            x = x + 1
          Next
        Next
      End If
    Next
    On Error GoTo shtAdd
    Set ws = Sheets(CStr(cd))
    On Error GoTo errHndlr
    With ws
      'データ書き出し
      .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(cnt - 1, CX).Value = v
      .Range("A1").CurrentRegion.Sort Key1:=.Range("A2"), _
                      Order1:=xlDescending, _
                      Header:=xlYes, _
                      OrderCustom:=1, _
                      MatchCase:=True, _
                      Orientation:=xlSortColumns, _
                      SortMethod:=xlStroke
    End With
  Next

errHndlr:
  Set mc = Nothing
  Set re = Nothing
  Set xh = Nothing
  With Err()
    If .Number <> 0 Then
      MsgBox .Number & vbLf & .Description
    End If
  End With
  Exit Sub

shtAdd:
  '新規コード時Sheet追加
  With Sheets.Add
    .Name = CStr(cd)
    .Columns(1).NumberFormat = "yyyy/mm/dd"
    .Range("A1").Resize(, CX).Value = w
  End With
  Resume
End Sub
'---------------------------------------------------------------------

>(私は、今回そこまでやるつもりはないですが)
...と書いておきながらやるワタシって...orz

Option Explicit
Sub test()
  Dim fromDate As Date '取得開始日
  Dim toDate  As Date '取得終了日
  Dim n    As Long
  Dim d, cds()

  'Dim t As Single
  't = Timer
  'toDateに取得終了日をセット可能
  toDate = Date '#8/31/2009#
  With Sheets("Sheet1")
    'B1セルから前回取得終了日をセット。最初は未入力で可
    d = .Range("B1").Value
   ...続きを読む

Q指定文字のみSheet1からSheet2へコピー

ExcelSheet1に表ー1のように氏名の列に記号が入力されています。
B列の指定記号(A,C,F,H)のみSheet2にVBAコードにてコピーしたいのですが。
尚、A列氏名は元々入力されています。
因みに、Sheet2の先頭列がSheet1と同様ですがコピー位置がE1等、任意に設定したいのですが。
どなたか解る方よろしくお願いします。

Aベストアンサー

>sheet2へ列をずらして(先頭列CをFへ)コピーできないでしょうか。どうかよろしくお願いします。

Sub ボタン1_Click()
Dim r As Range
ST = InputBox("元データの列")
EN = InputBox("挿入先の列")
For Each r In Range(ST & "1:" & ST & 10)
If WorksheetFunction.CountIf(Range("B10:B20"), r.Value) Then
Sheets("sheet2").Range(EN & r.Row).Value = r.Value
Else
Sheets("sheet2").Range(EN & r.Row).Value = ""
End If
Next
End Sub

こういった書き方は参考になるでしょうか。
エラー処理はしていません。
コピーしたい元データ列を取得する方法
データを入れたい列の取得する方法は?
とりあえず Inputbox にしましたが。

QVBA sheet2データーから平均取得 sheet1へコピー

sheet2指定セルデーターから平均
sheet1指定セルに取得したいのですがうまくいきません。

sheet1       sheet2
列A  列B 列C  列A  列B 列C
1  2 指定  1  2  3
1  2  3   1  2  3
1  2  3   1  2  3

sheet2・列C1~3の平均を、sheet1・指定セルに取得したいのですが

Sub test()
Dim r As Long, u As Long, ws1 As Object, ws2 As Object, y As Long

r = 10
u = 1

Set ws1 = Sheets(1)
Set ws2 = Sheets(2)

y = ws1.Range("A" & Rows.Count).End(xlUp).Row

Dim myAve As Long

myAve = Application.WorksheetFunction.Average(ws2.Range(Cells(3, u), Cells(7, u)))

ws1.Cells(r, 7).Value = "myAve"

r = r + 1

u = u + 1

End Sub

変数y r u を使いfor~nextでデーターを一括取得するつもりなのですが
この段階でうまくいきません。

sheet2指定セルデーターから平均
sheet1指定セルに取得したいのですがうまくいきません。

sheet1       sheet2
列A  列B 列C  列A  列B 列C
1  2 指定  1  2  3
1  2  3   1  2  3
1  2  3   1  2  3

sheet2・列C1~3の平均を、sheet1・指定セルに取得したいのですが

Sub test()
Dim r As Long, u As Long, ws1 As Object, ws2 As Object, y As Long

r = 10
u = 1

Set ws1 = Sheets(1)
Set ws2 = Sheets(2)

y = ws1.Rang...続きを読む

Aベストアンサー

>ws1.Cells(r, 7).Value = "myAve"
変数の使用方法が間違っています
ws1.Cells(r, 7).Value = myAve
>変数y r u を使いfor~nextでデーターを一括取得するつもりなのですが
う~ん、コードからは読み取れませんし、for~nextを使用するような内容でも無いと思います

質問のコードをなるべく使用すると
Sub test()
Dim r As Long, ws1 As Object, ws2 As Object, y As Long
r = 10
Set ws1 = Sheets(1)
Set ws2 = Sheets(2)
y = ws2.Range("C" & Rows.Count).End(xlUp).Row
ws1.Cells(r, 7).Value = Application.WorksheetFunction.Average(ws2.Range(ws2.Cells(1, 3), ws2.Cells(y, 3)))
End Sub
こんな感じ


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング

おすすめ情報