2011年01月23日

さくら咲け!

センター試験の次は桜かなー。ということで、久々に桜を折ってみました。「楊枝で差し込む」のところが面倒なので、裏にセメダイン木工用を少々塗り、親指と人差指で10秒ほどプレスしてます。「カツオで出汁をとる」とレシピにあるところを本だし使っちゃう感じかな。裏技というほど大層なものではありませんが、かなりラクに出来ます。
P1000430.JPG
posted by ちょびちょび at 19:30| Comment(46) | TrackBack(0) | 日記
この記事へのコメント
フォームにボタンを1個追加して下さい。ボタン名は仮にcmd実行2としています。
追加したボタンを右クリックしてコードの表示を選択したら下記の処理を貼り付けます。

Private Sub cmd実行2_Click()
Dim cn As Object
Dim rs As Object
Dim sPath As String
Dim vSQL As Variant
Dim maxRow As Integer
Dim maxRow2 As Integer
Dim i As Integer
maxRow = 20 '一覧(ボタンのあるシート)の最終行を求めてセットして下さい。
maxRow2 = 16 '応援依頼の最終行を求めてセットして下さい。
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
sPath = ThisWorkbook.Path & "\" & ThisWorkbook.Name
With cn
.Provider = "MSDASQL"
.ConnectionString = "Driver={Microsoft Excel Driver (*.xls)};" & _
"DBQ=" & sPath & "; ReadOnly=True;" & _
"Extended Properties=Excel 8.0; HDR=YES;"
.Open
End With
vSQL = "select T1.品名,T1.依頼日,T1.依頼先,count(T1.ロットNO) as 依頼数,first(T2.ロット数) as 依頼可能数 from [Sheet1$B4:K" & maxRow & "] as T1 "
vSQL = vSQL & "inner join [応援依頼$A1:C" & maxRow2 & "] as T2 on T1.依頼先=T2.依頼先 and T1.品名=T2.品名 "
vSQL = vSQL & "group by T1.品名,T1.依頼日,T1.依頼先 order by T1.依頼先,T1.品名,T1.依頼日"
Set rs = cn.Execute(vSQL)
Worksheets("Sheet1").Select
Range("M1:R1000").Select
Selection.Clear
Columns("O:O").NumberFormatLocal = "yyyy/m/d"

i = 5
Cells(i, 13) = "依頼先"
Cells(i, 14) = "品名"
Cells(i, 15) = "依頼日"
Cells(i, 16) = "依頼数"
Cells(i, 17) = "依頼可能数"
Cells(i, 18) = "依頼可能残数"

i = i + 1
Do Until rs.EOF
Cells(i, 13) = rs.fields("依頼先")
Cells(i, 14) = rs.fields("品名")
Cells(i, 15) = rs.fields("依頼日")
Cells(i, 16) = rs.fields("依頼数")
Cells(i, 17) = rs.fields("依頼可能数")
Cells(i, 18) = rs.fields("依頼可能数") - rs.fields("依頼数")
i = i + 1
rs.movenext
Loop
Set rs = Nothing
Unload frm依頼状況作成
End Sub
Posted by ちょびちょび at 2013年12月04日 21:49
お世話になります((。´・ω・)。´_ _))ペコ
おぉ・・・すばらしい・・素人目には不可能と思われてた依頼内容ですがまさに実現出来るとは!
コード改変して実行して動作確認出来ました!毎度毎度お忙しい中無茶なリクエストに対応して頂き誠に大変ありがとうございます!
アベノミ○スの影響からなのかなんと今年は年末年始がありません。会社で年越しが決定しましたがこのツールのおかげで今年は良い年越し&新年を迎えられそうです。何年振りかの年末年始仕事となりました。家族と過ごせないのはかなり痛いですが幼い娘の為に頑張ろうと思います!あー初詣にも行けないなぁ・・(´・ω・`)ガッカリ・・・
Posted by takoyakiudon at 2013年12月05日 06:46
おはようございます。
年越しは職場ですか。私は早くから会社員としては脱落していたので、問題が起こった会社にお邪魔して問題が解決したら去っていくという、ある意味ウルトラマン的な働き方をしてます。黙っていれば休日出勤なども避けられるのですが、子育てが終わったので、若い人が希望するなら休日出勤の交代なども買って出ます。今更会社員など希望していませんが、私のそんな行動は年寄りが必死に居場所を探して人事権のある人に取り入ろうとしているように見えるようで、わざわざ意地の悪い忠告をしてくれる人もいたりします。立場は全然違いますけど、偉い人とも同じ年代だったりしますからね。子どもの進学問題などで世間話をしている姿が取り入ろうとする姿に見えたりするらしいです。ブログの前はYahooの知恵袋などで気晴らしをしていましたが、そこでも意地の悪い人がいたりするんですよねー。
takoyakiudonさんの職場で少しでもお役に立てたなら嬉しいです。
Posted by ちょびちょび at 2013年12月06日 07:14
お世話になります((。´・ω・)。´_ _))ペコ
そうなんですか〜。色々大変なのですね・・。
職場にも色々な方が居られますので意地悪な方も居られますよね〜。(´・ω・`)
いつも大変助かっております。ワタクシも出世コースからは外れてしまった人間なので職場のみんなが楽になるようなツールを用意する事くらいしか出来ませんがこういう裏方的な仕事も悪く無いと思ってまして趣味の傍ら今後も精進していきたいと思っておりますのでご迷惑掛けますがまた質問させて下さい!
Posted by takoyakiudon at 2013年12月06日 14:12
お世話になります((。´・ω・)。´_ _))ペコ
SQL文を若干変更して指定した依頼内容を別シートに抽出させてみました。
vSQL = "select * from [経歴表$B4:K4" & maxRow & "] where 依頼先='" & Me.cmb依頼先 & "'"
vSQL = vSQL & " and 能力枠='" & cond(i) & "'"
vSQL = vSQL & " and 依頼内容='たこやき'"
vSQL = vSQL & " order by 依頼先,依頼日"
ここまでは自分で解かったのですが
メインのシートに依頼内容を抽出するSQLが複雑で出来ませんでした。

vSQL = "select T1.能力枠,T1.依頼日,T1.依頼先,count(T1.ロットNO) as 依頼数,first(T2.ロット数) as 依頼可能数 from [経歴表$B4:K4" & maxRow & "] as T1 "
vSQL = vSQL & "inner join [応援依頼$A1:D1" & maxRow2 & "] as T2 on T1.依頼先=T2.依頼先 and T1.能力枠=T2.能力枠 "
vSQL = vSQL & "group by T1.能力枠,T1.依頼日,T1.依頼先 order by T1.依頼先,T1.能力枠,T1.依頼日"
Set rs = cn.Execute(vSQL)
応援依頼シートに依頼内容をD列に追加して依頼内容も結果に反映させたいのですが(依頼内容に無いものは集計しない)可能でしょうか?また実行した際に1ヶ月前のメイン画面の一覧データを削除したいのですがこれまたご教授下さい。自分で組んでみましたが削除が上手くいかず・・(´・ω・`)

Posted by takoyakiudon at 2013年12月11日 18:14
■D列に依頼内容を追加して反映する
vSQL = "select T1.品名,T1.依頼日,T1.依頼先,count(T1.ロットNO) as 依頼数,first(T2.ロット数) as 依頼可能数,T2.依頼内容 from [Sheet1$B4:K" & maxRow & "] as T1 "
vSQL = vSQL & "inner join [応援依頼$A1:D" & maxRow2 & "] as T2 on T1.依頼先=T2.依頼先 and T1.品名=T2.品名 "
vSQL = vSQL & "where T2.依頼内容 <> '' "
vSQL = vSQL & "group by T1.品名,T1.依頼日,T1.依頼先,T2.依頼内容 order by T1.依頼先,T1.品名,T1.依頼日"

抽出するカラムを追加したらgroup by 句にも追加してあげましょう。countとかsumとかfirstの場合はgroup by 句への追加は不要です。依頼内容が無いものは集計しないということですので、「where T2.依頼内容 <> ''」を追加してみました。

■1カ月前を削除(言い方を変えると1カ月前より新しい日付を抽出する)
Dim date1M As Date
date1M = Format(DateAdd("m", -1, Now()), "yyyy/mm/dd")
vSQL = "select * from [Sheet1$B4:K" & maxRow & "] where 依頼日>#" & date1M & "# "
vSQL = vSQL & "order by ロットNO"

抽出したらデータを一旦クリアしてまた書き出してあげるといいでしょう。
日付が昇順に並んでいる保証があれば一か月前の日付がある行を判定して不要な行を削除してもいいかと思います。
Posted by ちょびちょび at 2013年12月11日 23:28
お世話になります((。´・ω・)。´_ _))ペコ
あれから前回教えて頂いた内容を四苦八苦しながらなんとか動作出来るようになりました。

<■1カ月前を削除(言い方を変えると1カ月前より新しい日付を抽出する)
なんですが
ユーザーフォームのSQLのほうはうまく一ヶ月分を抽出出来るのですが■D列に依頼内容を追加して反映する
方に組み込むとやり方が悪くてうまく行きません。。全件抽出されてしまいますので書き方をご教授お願いします。ちなみに
1週間前を削除⇒10日前を削除のコードも知りたいですが単純にmをwとかに変えてみればOKかと思いましたが動作しませんでした。。(´・ω・`)・・

前回「言い方を変えると1カ月前より新しい日付を抽出する」の内容だったのですが抽出元のメインのシートにあるデータ自体を削除する方法も知りたいです。

娘のクリスマスプレゼントを物色しに出掛けてました。まだ2歳ですが最近サンタの存在を知ったらしく楽しみにしているので何とも微笑ましい限りです。
Posted by takoyakiudon at 2013年12月22日 22:13
明日はクリスマスイブですね〜。お嬢さん2歳ですか。夢のある時期ですね。ウチはあれから20年経つのか……。

行を削除して上に詰めるの基本形はこんな感じです。
Range("B6:K6").Select
Selection.Delete Shift:=xlUp

これを応用して、依頼日が昇順に並んでいて纏めて削除できる場合と1行1行判定して不要行を削除する例を挙げておきます。1行ずつの場合は上から処理すると最終行が変わって処理に影響しますので、下から判定して削除します。1週間前と10日前の例も入れておきますね。wは惜しい。wwなんです。

Sub 依頼日が昇順に並んでいる場合()
Dim maxRow As Integer
Dim date7 As Date
Dim date10 As Date
Dim intDelete As Integer
Dim i As Integer
Worksheets("Sheet1").Select
maxRow = Range("E5").End(xlDown).Row
date7 = Format(DateAdd("ww", -1, Now()), "yyyy/mm/dd")
date10 = Format(DateAdd("d", -10, Now()), "yyyy/mm/dd")
For i = 6 To maxRow
If date7 <= Cells(i, 5) Then
intDelete = i
Exit For
End If
Next
Range("B6:K" & intDelete).Select
Selection.Delete Shift:=xlUp
End Sub

Sub 依頼日が順不同な場合()
Dim maxRow As Integer
Dim date7 As Date
Dim i As Integer
Worksheets("Sheet1").Select
maxRow = Range("E5").End(xlDown).Row
date7 = Format(DateAdd("ww", -1, Now()), "yyyy/mm/dd")
For i = maxRow To 6 Step -1
If date7 >= Cells(i, 5) Then
Range("B" & i & ":K" & i).Select
Selection.Delete Shift:=xlUp
End If
Next
End Sub

D列に依頼内容を追加して反映する方がうまく抽出できないというのは、
vSQL = vSQL & "where T2.依頼内容 <> '' "
に依頼日の判定も追加する、でよろしいでしょうか?
vSQL = vSQL & "where T2.依頼内容 <> '' and T1.依頼日 >#" & date1M & "# "
Posted by ちょびちょび at 2013年12月23日 20:48
お世話になります((。´・ω・)。´_ _))ペコ
おぉ、ありがとうございます。ちなみにデータを削除するのではなく別bookなどにバックアップを作成する場合はどのようなコードを作成すれば良いでしょうか??
Posted by takoyakiudon at 2013年12月25日 14:51
そういえばサンプル作成して頂いた当初DドライブにBOOKが保存されるしくみだったと思いますがBOOKがどんどん増えて行くのは困るので上書きしていくような感じが良いです。別にDドライブでなくても構いませんがよろしくお願いします((。´・ω・)。´_ _))ペコ
Posted by takoyakiudon at 2013年12月27日 15:26
ご無沙汰しております((。´・ω・)。´_ _))ペコ
私も3月に家を購入しローン地獄に足を踏み入れましたw
頑張っていきたいです。ちょびさんはお元気ですか?
環境がまた変化して多忙な日々を過ごしてらっしゃるんでしょうね〜
Posted by takoyakiudon at 2014年05月26日 03:04
お久しぶりです。
おお。新居を購入されたのですか。大変ではありますけど、モチベーション上がりますよね。
母が孫の通う大学を見たいというので先月大阪に行ってきました。造幣局の桜通り抜けの時期だったからか宿が取れなくて帝国ホテル5万円とビジネスホテル5千円の選択を迫られました。去年遊びに行った北大は見学するところが沢山あったのに、吹田キャンパスは耐震工事中の建物と竹藪しかありませんでした。
4月から職場が少しだけ近くなりました。毎月メンバーが増える活気のある職場です。スキルシートに「医」とか「薬」とかいう文字列があると無条件に配属されるという噂のある薬局チームというところにいます。
Posted by ちょびちょび at 2014年05月26日 22:17
お元気そうで安心いたしました。((。´・ω・)。´_ _))ペコ
ほほう、なかなか大変そうな職場ですねぇ・・。

半年前↑にあります質問をさせて頂きました。
今まであれこれ自分でチャレンジしてきましたがなかなか上手くいきません。ご教示願いたいです。お時間よろしい時にお願いします。

あと追加で質問なんですが会社でIBMのロータスノーツのソフトを使用してますがそのノーツのデータベースからエクセルVBAで情報を取り込みたいのですがサイトなどをみていると↓のようなコードで抽出出来るっぽいんです。

ですがデータベースが開かれてないってエラーが出まして・・。ちなみにサーバーとファイルパスは正しく設定しております。ビューを取得のところでエラーになります。どうしてでしょうね??

IBM Lotus Notes データベースにアクセスし、値を取得するサンプル
Option Explicit

Private Sub CommandButton1_Click()
Dim Ans, session, db, View, doc, i, strShtName, Value01, Value02

Ans = MsgBox("実行しますか?", vbYesNo, "実行確認")
Select Case Ans
Case vbNo
Exit Sub
End Select

Set session = CreateObject("Notes.NotesSession")
'##### アクセスするデータベースのサーバー名とファイルパス
Set db = session.GetDatabase("server", "dir\file.nsf")
'##### ビューを取得
Set View = db.getView("view01")

i = 2
Set strShtName = ActiveSheet
Set doc = View.GetFirstDocument
Do Until doc Is Nothing
Value01 = doc.GetItemValue("DB_Value01")
Value02 = doc.GetItemValue("DB_Value02")

strShtName.Cells(i, 2) = Value01(0)
strShtName.Cells(i, 3) = Value02(0)

Set doc = View.GetNextDocument(doc)
i = i + 1
Loop
Posted by takoyakiudon at 2014年05月28日 14:52
こんばんは。

Set session = CreateObject("Notes.NotesSession")
のところですが、
Set session = CreateObject("Lotus.NotesSession")
という書き方もあるようですね。OLEとCOMっていうのかな。

Set db = session.GetDatabase("server", "dir\file.nsf")
のとろこですが、サーバ名を省略するとどのような動作になりますか?
Set db = session.GetDatabase("", "dir\file.nsf")

あと、Notesって(他のDBでもそうですが)アクセス権とか色々設定されているじゃないですか。接続までは許可されているけど、参照権は無いとかいうことはありませんか?
Posted by ちょびちょび at 2014年05月29日 21:43
お世話になります((。´・ω・)。´_ _))ペコ

<サーバ名を省略するとどのような動作になりますか?
↑ちょっと月曜日会社で確認してみます・・。
接続と参照が許可されてるファイルなんですがノーツ自体を閉じてからマクロ実行するとログインパスワード入力画面が開き立ち上がってくれますがそこでデータベースが開かれてないと言われますね〜
Posted by takoyakiudon at 2014年05月31日 02:25
お世話になります。((。´・ω・)。´_ _))ペコ
ちょっとばたばたしておりまして確認が遅れましたがサーバー名を省略すると「値がありません」とエラーになりました。
指定しても'##### ビューを取得
Set View = db.getView("view01")
の所がエラーとなりますが調べた所ここでいうViewとはNotesのViewの事らしいですね。
Notesは日付順や分類別、作成者別など様々な一覧でみることができますが、これがビューみたいで
ただプログラムで扱う「ビュー名」は「作成者別一覧」のような日本語名ではなく
アルファベットで付けられた「別名」の方だと思います。
(もしかしたら日本語名でもできるかもしれませんが)


対象のビューを選択した状態で上部メニューからアクション→ビューオプション
→設計と選択して設計メニューを開き、さらに本体側で「ビューの選択」をクリックすると
メニュー上にビューの別名が出ますがそれを指定すれば可能かも知れないみたいですが
<あと、Notesって(他のDBでもそうですが)アクセス権とか色々設定されているじゃないですか。接続までは許可されているけど、参照権は無いとかいうことはありませんか

言われるように開発者の権限とかあるのでこれ以上踏み込まないほうが良いでしょうね〜

ちなみにワードに貼ってある写真をエクセルに貼り付けるコードってお解りになられますか?エクセルからワードって良く紹介されてたりしますがワードに貼ってある大量の写真をエクセルで整理したいのでエクセルに貼り付けしたいのですが・・。
Posted by takoyakiudon at 2014年06月11日 14:15
ワードに貼り付けた写真をエクセルに貼り付け会社の同僚に無理だと言われたんですが出来ませんっけ??(´・ω・`)はて?
Posted by takoyakiudon at 2014年06月13日 05:46
昨日、ちょっと調べただけではワード⇔エクセルのオブジェクト相互参照(?)みたいな技は見つかりませんでしたねー。ワードの画像を全部選択、みたいなことはできるので、それをどこかのフォルダに画像として保存できればそれをエクセルから拾ってまとめて貼るというツールの方は倉庫にあります。ちょっと週末調べてみましょう。
Posted by ちょびちょび at 2014年06月13日 07:10
おぉ。。ありがとうございます((。´・ω・)。´_ _))ペコ
期待しております
Posted by takoyakiudon at 2014年06月14日 05:16
お疲れ様です。催促するようで申し訳ありませんが見つかりましたでしょうか?(≧∇≦)会社にある顕微鏡のような機器で映像が残せるのですがワードに写真が取り込まれるのでExcelで編集する必要があり困っております・・
Posted by takoyakiudon at 2014年06月21日 23:07
お世話になります。((。´・ω・)。´_ _))ペコ
ワードの画像をエクセルに貼り付けですがあれから自分でもネットなどで探してるのですが全く見当たりませんでした。。

ちなみに写真を配列で指定したセルの場所に貼るマクロがあり配列を増やしたりしてかなり自分好みのマクロなんですが写真が名前とか作成日順に貼れなくて検索掛けましたがさっぱり解らずコードを教えて頂きたいです。



Sub 画像貼り付け()

'===============フォルダ選択
Set myPath = CreateObject("Shell.Application") _
.BrowseForFolder(&O0, "フォルダを選んでください", &H1 + &H10, 0)
If myPath Is Nothing Then Exit Sub
If myPath.Items Is Nothing Then Exit Sub
If myPath.Items.Item Is Nothing Then Exit Sub
フォルダ = myPath.Items.Item.Path
Set myPath = Nothing

'===============画像の掃除
' For Each mySP In ActiveSheet.Shapes
' myAD1 = mySP.TopLeftCell.MergeArea.Address
' myAD2 = Target.Address
' If myAD1 = myAD2 Then mySP.Delete
' Next

元シト = ActiveSheet.Name
セル = Array("C2", "AO2", "C17", "AO17", "C32", "AO32", "C47", "AO47")
i = 8
Set myFS = CreateObject("Scripting.FileSystemObject")
For Each myF In myFS.GetFolder(フォルダ).Files
myEXT = LCase(myFS.GetExtensionName(myF))
If myEXT = "jpeg" _
Or myEXT = "jpg" _
Or myEXT = "gif" _
Or myEXT = "tiff" _
Or myEXT = "bmp" _
Or myEXT = "png" _
Or myEXT = "tif" Then
If i > 7 Then
i = 0
Sheets(元シト).Copy after:=Sheets(Sheets.Count)
End If
'===============画像の貼り付け
Set mySP = ActiveSheet.Pictures.Insert(myF)
myMA = Range(セル(i)).MergeArea.Address
'===============タテヨコの縮尺を保持
myHH = Range(myMA).Height / mySP.Height
myWW = Range(myMA).Width / mySP.Width
If myHH > myWW Then
mySP.Height = mySP.Height * myWW
mySP.Width = Range(myMA).Width
Else
mySP.Height = Range(myMA).Height
mySP.Width = mySP.Width * myHH
End If

'===============中央へ調整
myHH2 = (Range(myMA).Height / 2) - (mySP.Height / 2)
myWW2 = (Range(myMA).Width / 2) - (mySP.Width / 2)
mySP.Top = Range(myMA).Top + myHH2
mySP.Left = Range(myMA).Left + myWW2

Set mySP = Nothing
i = i + 1
End If
Next
Set myFS = Nothing

End Sub



Posted by takoyakiudon at 2014年06月27日 09:30
う〜ん。ギブアップです。自動化できない……。
途中まで作成していたものがありますので、アップしますね。

http://www.bec-co.sakura.ne.jp/dataland/Repository.php

使い方としてはこんな感じです。

@ShapesArrange.xlsm を開いて整理整頓シートの図形シートクリアボタンをクリックする。
Awordを開いて図形を全部選択、コピーし、excelの作業シートに貼る。
B図形一覧作成ボタンをクリックする。
C図形一覧シートに出来ている一覧をexcelの機能でソートするか手動で並べ替える。
D整理整頓ボタンをクリックする。

作業シートには見本の図形が貼り付けられていますので@、Aは省略して下さい。
図形一覧で取得できるのは名前とかサイズぐらいです。ファイルなら作成日とか持ってますが、ブックやドキュメント内の図には作成日情報ありません。図形一覧マクロのあたりを参照して並べ替えを工夫して下さい、ぐらいしかアドバイスできません。申し訳ない。
Posted by ちょびちょび at 2014年06月29日 18:03
おぉ・・お忙しいところありがとうございます!
。((。´・ω・)。´_ _))ペコ
やってみます!
ちなみに↑の6/27の私からの書き込みであのコードで名前とか作成日順にシートに貼るにはどうしたら良いでしょう??バブルソートなど検索してみましたがあれに組み込み方が解りません。。
Posted by takoyakiudon at 2014年06月30日 15:11
Sheet1追加しましたので、画像張付ボタン押してみて下さい。

http://www.bec-co.sakura.ne.jp/dataland/Repository.php
Posted by ちょびちょび at 2014年06月30日 22:15
おぉ・・大変お忙しい中急なお願いで申し訳ありませんでした!非常に助かります!
。((。´・ω・)。´_ _))ペコ
ついでと言ってはなんですがsqlで抽出させたデータがB5からI5までフィールドがありそれが下に向かって大量に並んでいます。そのデータ自体は日付の検索条件で抽出させたものなんですが(日付のデータはG列です)それをピボット&棒グラフにしています。単純にデータ自体をフィルタすれば良いですが作業を楽にしたくて月の週ごとにデータまとめる為に(月から日曜)例えば今日2014/7/2水曜ですが2014/6/30月曜〜本日の2014/7/2水曜まで、明日bookをみたら2014/6/30月曜〜2014/7/3木曜までのデータを表示、次の月曜日は2014/7/7なので開始日が2014/7/7から・というように完全にカレンダーの月曜〜日曜までのデータとして自動でまとめる方法がありましたらご教授願いたいです。
カレンダーがVBAで作成出来る事を考えると可能なのかな?と思いましたが・・。解りにくい質問で申し訳ありません。
Posted by takoyakiudon at 2014年07月02日 10:11
こんな感じです。グラフは好きな種類に変えて下さい。

Sub Macro1()
Dim i As Integer
Dim sDate As Date
Dim eDate As Date
Dim maxrow As Integer
Dim sRow As Integer
Dim eRow As Integer
i = Weekday(Now())
'月曜日だったら当日から一週間
If i = 2 Then
sDate = Format(Now(), "yyyy/mm/dd")
eDate = DateAdd("d", 7, Format(Now(), "yyyy/mm/dd"))
Else '月曜日以外だったら一番近い過去の月曜日から一週間
If i = 1 Then
i = i + 7
End If
sDate = DateAdd("d", (i - 2) * -1, Format(Now(), "yyyy/mm/dd"))
eDate = DateAdd("d", 7, sDate)
End If
maxrow = Range("G5").End(xlDown).Row
'開始行判定
For i = 6 To maxrow
If Range("G" & i) >= sDate Then
sRow = i
Exit For
End If
Next
'終了行判定
For i = sRow + 1 To maxrow
If Range("G" & i) >= eDate Then
eRow = i
Exit For
End If
Next
'グラフ作成
Range("B5:I5", "B" & sRow & ":I" & eRow).Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.SetSourceData Source:=Range("B5:I5", "B" & sRow & ":I" & eRow)
ActiveChart.ChartType = xlColumnClustered
End Sub
Posted by ちょびちょび at 2014年07月02日 23:04
おぉ・・!非常に助かります!
。((。´・ω・)。´_ _))ペコ
ちなみにこの日付のルールでシートのデータを別シートにADOで抽出させたいのですがSQL文とVBA構文がかなり複雑になりそう?というか可能なのでしょうか?
Posted by takoyakiudon at 2014年07月06日 10:59
'グラフ作成 というコメントの下で範囲を選択するところがありますよね。
Range("B5:I5", "B" & sRow & ":I" & eRow).Select ←これ

Variant型の変数を宣言してこんな感じに書くとSheet1からSheet2にデータがコピーできます。

Dim C As Variant
Worksheets("Sheet1").Select
C = Range("B5:I5", "B" & srow & ":I" & erow)
Worksheets("Sheet2").Select
Range("B5:I5", "B" & srow & ":I" & erow) = C

前回の見本もG列の日付が昇順に並んでる前提で書いちゃいましたけど、順番が保証されていないようでしたら、フィルターの方がいいのかな……。

Dim C As Variant
Worksheets("Sheet1").Select
Columns("G:G").Select
Selection.AutoFilter
ActiveSheet.Range("B5:I5", "B" & sRow & ":I" & erow).AutoFilter Field:=1, Criteria1:=">=" & sDate, _
Operator:=xlAnd, Criteria2:="<=" & eDate
Range("B5:I5", "B" & sRow & ":I" & erow).Select
Selection.Copy
Sheets("Sheet2").Select
ActiveSheet.Paste
Posted by ちょびちょび at 2014年07月06日 22:34
おぉ・・!非常に助かります!
。((。´・ω・)。´_ _))ペコ
とりあえず自宅PCで生データを使用してやってみました。(オラクル環境がない為あらかじめ保存していたデータだけ使用)
試しに生データのG列の日付を6/20〜7/25に入れてみましたが6/20〜7/14までの24日分のデータがコピーされました。未来の日付を入れたらおかしくなるのかな?と直近の日付に変更してみましたがRANGEメソッドは失敗しました。グローバルオブジェクトエラーが出ます。 C = Range("B5:I5", "B" & sRow & ":I" & eRow)がエラー表示となります。これは生データがおかしいのですかね????(´・ω・`)はて?'月曜日だったら当日から一週間・Else '月曜日以外だったら一番近い過去の月曜日から一週間・としている事から考えると過去の日付のデータが入っているとエラーとなりますか?うむむ。
Posted by takoyakiudon at 2014年07月07日 02:23
ごめんなさい。
C = Range("B5:I5", "B" & srow & ":I" & erow)
の"B5:I5"は見出しなんで、この書き方だと先頭データからコピーしちゃいます。
以下のように修正すれば7日から14日(あ。これも13日まででいいのかな。修正して下さい)のデータがコピーされます。また、前回のままだとコピー先もSheet1と同じ行になっちゃうので、都合のいい行に編集して下さい。見出しは別途編集するかコピーして下さい。

Worksheets("Sheet1").Select
C = Range("B" & sRow & ":I" & eRow)
Worksheets("Sheet2").Select
Range("B6:I" & eRow - sRow) = C
Posted by ちょびちょび at 2014年07月07日 06:53
おぉ・・!無事動きました!
。((。´・ω・)。´_ _))ペコ
これは便利ッス!

ちなみに↑で紹介して下さったフィルターverもレンジを("B" & sRow & ":I" & eRow)に変更して試しましたが2014/7/07のみ転記されたり2014/7/14まで転記されたり挙動が安定しません。マクロ実行後「リソース不足のためこのタスクを完了することができません。選択するデータを少なくするかほかのアプリケーションを終了して再度試してください。」と出る事もあります。こちらもこちらで便利なのでネタとしてストックしておきたいです。最後に元データに掛けたフィルターを解除してマクロ実行前の状態にもどして起きたいです。(マクロの記録でコード自体は後で付け足せますが・・。)我儘ばかりで申し訳ありません。
Posted by takoyakiudon at 2014年07月07日 12:50
ActiveSheet.AutoFilterMode 判定入れてみました。

Sub macro2()
Dim maxrow As Integer
Dim i As Integer
Dim sDate As Date
Dim eDate As Date
maxrow = Range("G5").End(xlDown).Row
i = Weekday(Now())
'月曜日だったら当日から一週間
If i = 2 Then
sDate = Format(Now(), "yyyy/mm/dd")
eDate = DateAdd("d", 7, Format(Now(), "yyyy/mm/dd"))
Else '月曜日以外だったら一番近い過去の月曜日から一週間
If i = 1 Then
i = i + 7
End If
sDate = DateAdd("d", (i - 2) * -1, Format(Now(), "yyyy/mm/dd"))
eDate = DateAdd("d", 7, sDate)
End If
Application.CutCopyMode = False
If ActiveSheet.AutoFilterMode = True Then
Selection.AutoFilter
End If
Range("G5").Select
Selection.AutoFilter
ActiveSheet.Range("$B$5:$I$" & maxrow).AutoFilter Field:=6, Criteria1:= _
">=" & sDate, Operator:=xlAnd, Criteria2:="<" & eDate
Range("B5:I" & maxrow).Select
Selection.Copy
Sheets("Sheet2").Select
Cells(2, 5).Select
ActiveSheet.Paste

End Sub
Posted by ちょびちょび at 2014年07月12日 20:12
おぉ・・!ありがとうございます。((。´・ω・)。´_ _))ペコ
上記を含め思っていた結果が残せるようになり大変効率が上がりました。感謝、感謝です!
Posted by takoyakiudon at 2014年07月14日 12:56
お久しぶりです。寒くなってきたなー。と思ったらもう12月。一年って早いですよね〜。娘も先月七五三を終えたと思ったら6月には二人目の子供が生まれます。今年は家も建て引っ越ししたり多忙な一年でした・・
Posted by takoyakiudon at 2014年11月30日 05:38
おめでとうございます。今度の夏、楽しみですねー。1年は早いけど、毎日は大変な日もあるでしょう。あまり頑張らないで寒い時期を乗り切って下さいね。
今年は閉店した映画館を活用してのコミュニティシネマ活動に参加しました。そのご縁で、まず大人が単独では観ないであろう聖闘士星矢とかも観てしまいました。で、ストーリーはともかく、綺麗な映像には意外とヒーリング効果もあることを発見しました。アナ雪もすごく綺麗でしたよね。最近のお勧めはガーディアンズ・オブ・ギャラクシー。映画のツボを見事に押さえた楽しい作品です。
Posted by ちょびちょび at 2014年12月07日 11:07
ご無沙汰しております。
お元気でしょうか?5月に2人目の子供も生まれ(今度は男の子でした)子育てに奮闘しつつ仕事も頑張っております。
またご質問させて頂きますが製品に伝票が付いておりロットNOが記載されてます。そのロットNOはその製品の箱の中に複数表示されておりそれらの表示数はランダムというかバラバラで多かったり少なかったりします。(伝票、箱、製品の袋、(袋の数がランダムで多かったり少なかったりする)指示書)他のロットNO(製品)が混入しない様に目視で確認していたのですがバーコードでロットNOを読み取って全て同じだったら照合OKと表示されその結果を記録するツールみたいなのを作ろうと考えてます。出来ればユーザーフォームを出現させて作業者に入力させもし異なったロットNOだったらエラー表示させ確認を促すような・・といえば良いのでしょうか・・。お知恵をお借りしたいです。
Posted by takoyakiudon at 2015年09月17日 08:39
お子さんのお誕生おめでとうございます。しかも、もう職場に復帰されているのですか。私は高齢での出産ということもあったけど、半年ぐらいは体調くずしやすかったです。頑張るなと言っても無理なのは承知ですが、くれぐれも体調には気をつけて下さい。
さて、バーコードリーダーですが、USB接続で3,000円ぐらいのものが販売されてますので、結構気軽にAccessで使えますよ。カーソルがテキストボックスにある状態で「P!」とかすると普通に数字が出てきたりします。いくらなんでもこれ以上は入ってこないだろうという数のテキストボックスを用意し、読み込ませて最後一気に判定、みたいなものでしたらそれほど難易度は高くないかと思います。しかし、2〜3万程度のものが多数販売されていたような気がしますので、業務用となると数千円では耐久性とかに問題があるのかもしれません。まあ、パソコン用にバーコードリーダー買ってもらえるかどうかという問題もありますが。
バーコードリーダーとパソコンの直接接続は無理という場合でも判定のロジックは一緒だと思います。判定のタイミング(全部読み込んで最後に判定で良いのか、2個以降目読みこんだらそれまでと比較して違ってたらその都度お知らせとか)などを教えてもらえたらもう少し具体的なアドバイスができるかと思います。
Posted by ちょびちょび at 2015年09月18日 06:59
お世話になります。バーコードリーダーはPCと接続しております。、読み込ませて最後一気に判定で良いです。
例えば ユーザーフォームで
ロットNO
ロットNO ロットNO
ロットNO ロットNO
ロットNO ロットNO
ロットNO ロットNO   ←テキストBOX

入力 キャンセル   ←ボタン

みたいなイメージで入力ボタンを押すと
違うロットNOが一つでもあったらそのロットNOの場所が
赤表示になるような・・。

ちなみにロットNOを読み込ませたら自動で次のテキストBOXにタブで飛んでくれると楽ちんですねぇ
Posted by takoyakiudon at 2015年09月19日 08:15
自宅の環境にはAccessがないので、取りあえずExcelでイメージを作ってみました。A列のロットNOを適当に変更してボタンをクリックしてみて下さい。

http://www.bec-co.sakura.ne.jp/dataland/Repository.php
Posted by ちょびちょび at 2015年09月19日 23:43
おぉ!ありがとうございます!アクセスではなくExcelでOKですよ!
ちなみにユーザーフォームでやる場合のサンプルもお手数ですがお願い出来ますか??ユーザーフォームだと難しいのでしょうか??。。
Posted by takoyakiudon at 2015年09月20日 03:32
ユーザーフォームだったらこんな感じです。
Book222をBook333にして入れ替えてあります。
http://www.bec-co.sakura.ne.jp/dataland/Repository.php
Posted by ちょびちょび at 2015年09月20日 07:54
おぉ!!かなり良いですね!これでかなりイメージ通りです。ちなみにテキストBOX1にデータが入力してありテキストBOX2が空欄でテキストBOX3にデータが入ってるなどの入力ミス状態だと実行前にエラー出せたりしますか??また処理が終了した完全一致してOKだったロットNOのデータ(製品の伝票のロットNO、つまりSheet1のA2のデータ)1件だけを別のSheet2のB2辺りから下に向かって転記して経歴を残して行きたいのですが可能ですか?
Posted by takoyakiudon at 2015年09月20日 14:27
Posted by ちょびちょび at 2015年09月20日 20:49
ありがとうございました!とってもイメージ通りです。さっそく有効に活用させて頂きます!助かります!
Posted by takoyakiudon at 2015年09月24日 22:44
お久しぶりです。長女ももうすぐ5歳になり下の子も最近つかまり立ちが出来る様になりました。子供の成長を感じられ毎日楽しく過ごしております。PCは中々覚えれませんがw
Posted by takoyakiudon at 2016年03月26日 06:26
takoyakiudonさん。
スクロールが辛くなってきましたので、下記の記事に引っ越しますね。

http://chobi2dataland.sblo.jp/article/165654036.html
Posted by ちょびちょび at 2016年04月02日 08:28
コメントを書く
お名前:

メールアドレス:

ホームページアドレス:

コメント:

この記事へのトラックバックURL
http://blog.sakura.ne.jp/tb/42802570

この記事へのトラックバック