目安箱 IV

目安箱投稿のルールはこちらをごらんください。
ご意見は電子メールで承っています。
「目安箱」は質問禁止です。技術的な質問はそれぞれの質問箱へどうぞ。

迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃ホーム  
2 / 14 ﾍﾟｰｼﾞ ←次へ　｜　前へ→
【278】企業名を入れると企業番号が出るようにした...
Access  りぃな  - 15/3/6(金) 8:21 -
引用なし
パスワード
   企業名を入れると企業番号が隣のセルに自動で出るようにしたいんですが、作り方が分りません。
アクセス初心者です。
イチイチコピペしてます。
宜しくお願いします。
解りやすく教えて下さい。
・ツリー全体表示
【277】VBでExcellのSubを走らせることが出来ますか
Excel  Kチャン E-MAIL  - 13/8/15(木) 20:55 -
引用なし
パスワード
   VBでExcellを使ったプログラミングをしていますが、VBでプログラミングする
より、ExcellのVBAが使えたら便利なことがあると思いますが、その様なことが
出来るのでしょうか。お教えください。
　例えば、VBAでExcellのA5:F5列をコピーし、A10:F10にペーストすると言う様な
Sub CopyPaste（本来はもっと複雑なVBAですが。）がSheet2にあったとしたら、
VBでそのSub CopyPasteを指示すれば上記の様なコピー、ペーストが出来るなどです。
　よろしくお教えください。
・ツリー全体表示
【276】テーブル更新について
Access  VBA初心者です E-MAIL  - 11/11/27(日) 20:20 -
引用なし
パスワード
   VBA初心者です。
テーブルAを参照して同じサービス書番号のテーブルB２つのフィールドをテーブルAの内容に更新するクエリを作成したのですが、
「メソッドまたはデータメンバが見つかりません」というエラーになります。
初歩的なことだとは思うのですが、行き詰っております。
どなたか教えていただけませんでしょうか。
よろしくお願いいたします。


Private Sub 使用日更新_Click()

Dim CN As dao.Connection
Dim rsA As dao.Recordset
Dim rsB As dao.Recordset
Set CN = CurrentProject.Connection
rsA.Open "T_使用", CN, adOpenKeyset, adLockOptimistic
rsB.Open "T_サービス書", CN, adOpenKeyset, adLockOptimistic
　Do Until rsA.EOF
　　　rsB.Filter = " サービス書番号 = '" & rsA!サービス書番号 & "'"
　　　If rsB.EOF Then
　　　　　rsB.AddNew　　
　　　　　rsB!使用日 = rsA!サービス書使用日
　　　　　rsB!使用社員番号 = rsA!使用社員
　　　　　rsB.Update
　　　End If
　　　rsA.MoveNext
　Loop
rsB.Close: Set rsB = Nothing
rsA.Close: Set rsA = Nothing
CN.Close: Set CN = Nothing


End Sub
・ツリー全体表示
【275】複数ファイルから、対象データの抽出
Excel  VBA初心者  - 11/10/24(月) 10:52 -
引用なし
パスワード
   こんにちは、VBA初心者です。
過去のファイルを管理しやすいように、VBAにて検索＆表示画面を作ろうかと思ったんですが、うまくいきません。。
色々なサイトで紹介されているプログラミングを参考に、以下のコードを作成しました。

複数個ある、過去ファイルから条件に合う行をそれぞれ一行ずつコピーして一覧を作成したいのですが、フィルタまではうまく動くのですが、タイトル行を削除しようとするとエラーになります。
(下記プログラムで★の部分)
どうやら原因はtbl.Rows.Count の値が1になっているようなのですが、最後の「 Workbooks(b4Table.Name).Close SaveChanges:=False」をコメントアウトして、ファイルを表示してみるとタイトル行以外にも一行表示されています。。。

VBA上級者の皆様の力を貸して下さい。よろしくお願いします！
ちなみにExcel2007を使ってます。

Sub display()

Dim b4Table As Object
Dim fso As Object
Dim CasNo, Row As Integer
Dim CalNo As String

Set fso = CreateObject("Scripting.FileSystemObject")
Row = 7
Application.ScreenUpdating = False
　　
　　 For Each b4Table In fso.GetFolder(ThisWorkbook.Path & "\before\").Files
　　
　　　　CalNo = "A" & Row
　　　　
　　　　Workbooks.Open Filename:=ThisWorkbook.Path & "\before\" & b4Table.Name
　　　　
　　　　If ActiveSheet.AutoFilterMode Then
　　　　　　ActiveSheet.AutoFilterMode = False
　　　　End If

　　　　Workbooks(b4Table.Name).Worksheets(1).Range("1:500").AutoFilter _
　　　　field:=5, Criteria1:=ThisWorkbook.Worksheets(1).Range("C2")
　　　　Range(CalNo).CurrentRegion.Select
　　　　Set tbl = Range(CalNo).CurrentRegion.SpecialCells(xlCellTypeVisible)
　　　　MsgBox ("tbl.Rows.Count = " & tbl.Rows.Count)

　　　　　　★tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count).Select
　　　　　　tbl.Copy ThisWorkbook.Worksheets(1).Range(CalNo)
　　　　　　tbl.AutoFilter
　　　
　　　　 Workbooks(b4Table.Name).Close SaveChanges:=False
　　　　
　　　　Row = Row + 1
　　 Next

Application.ScreenUpdating = True

Set fso = Nothing

End Sub
・ツリー全体表示
【274】CSVファイルから16桁以上の数値を取得したい
Excel  初心者  - 11/10/19(水) 12:21 -
引用なし
パスワード
   初めまして。VBA初心者です。
現在、指定した条件をキーにCSVファイルから合致したレコードをexcelに出力するマクロを作成しています。con.Executeを用いています。
CSVファイルの1つのカラムが数値16桁以上になっており、出力した結果値が四捨五入されてしまいます。
四捨五入されないで正確に値を取得する方法はあるのでしょうか？

ご回答頂けると助かります。
・ツリー全体表示
【273】DOS用短いフルパス
Excel  Jaka  - 11/4/28(木) 15:22 -
引用なし
パスワード
   パスが長すぎてエラーになったりするShellなんかに役に立つと思います。

DOS用短いフォルダパス

MsgBox CreateObject("Scripting.FileSystemObject").GetFolder("フォルダパス").ShortPath

DOS用短いファイルパス

MsgBox CreateObject("Scripting.FileSystemObject").GetFile("フルパスファイル名").ShortPath
・ツリー全体表示
【272】Re:inputboxで入力した数値が正しく反映さ...
Excel  Jaka  - 11/3/9(水) 15:08 -
引用なし
パスワード
   Dim i As Double
Dim a As Double

因みに、ここ（目安箱）は質問するところではないです。
・ツリー全体表示
【271】inputboxで入力した数値が正しく反映されな...
Excel  hirobon E-MAIL  - 11/3/6(日) 23:35 -
引用なし
パスワード
   Inputboxでレートを入力し、該当セルに反映させたいのですが、なぜか下記複数インプットボックスがある中で、"a"と、"g"のみなぜか小数点が切り上げされてしまいます。(例) inputobox= \81.135⇒セル=\82.000-など

該当セル確認しましたが、他のセルの書式と全く同じで、なにが原因が検討がつきません....　この件解決策お分かりの方いらっしゃいましたら、お教えいただけますでしょうか？？？

よろしくお願い致します。

***下記VBA内容載せておきます***
///////////////////////////////////////////////////////////////////////
Sub 3.Aレート記入()

Dim i As Integer
Dim a As Integer

a = Application.InputBox(prompt:="1月レートを入力してください", Type:=1)
b = Application.InputBox(prompt:="2月レートを入力してください", Type:=1)
c = Application.InputBox(prompt:="3月レートを入力してください", Type:=1)
d = Application.InputBox(prompt:="4月レートを入力してください", Type:=1)
e = Application.InputBox(prompt:="5月レートを入力してください", Type:=1)
f = Application.InputBox(prompt:="6月レートを入力してください", Type:=1)
g = Application.InputBox(prompt:="7月レートを入力してください", Type:=1)
h = Application.InputBox(prompt:="8月レートを入力してください", Type:=1)
i = Application.InputBox(prompt:="9月レートを入力してください", Type:=1)
j = Application.InputBox(prompt:="10月レートを入力してください", Type:=1)
k = Application.InputBox(prompt:="11月レートを入力してください", Type:=1)
l = Application.InputBox(prompt:="12月レートを入力してください", Type:=1)

Worksheets("RegionPrice貼り付けシート").Cells(1, 9) = a
Worksheets("RegionPrice貼り付けシート").Cells(1, 11) = b
Worksheets("RegionPrice貼り付けシート").Cells(1, 13) = c
Worksheets("RegionPrice貼り付けシート").Cells(1, 15) = d
Worksheets("RegionPrice貼り付けシート").Cells(1, 17) = e
Worksheets("RegionPrice貼り付けシート").Cells(1, 19) = f
Worksheets("RegionPrice貼り付けシート").Cells(1, 21) = g
Worksheets("RegionPrice貼り付けシート").Cells(1, 23) = h
Worksheets("RegionPrice貼り付けシート").Cells(1, 25) = i
Worksheets("RegionPrice貼り付けシート").Cells(1, 27) = j
Worksheets("RegionPrice貼り付けシート").Cells(1, 29) = k
Worksheets("RegionPrice貼り付けシート").Cells(1, 31) = l

End Sub
//////////////////////////////////////////////////////////////
・ツリー全体表示
【270】動かない原因２．
全般  Jaka  - 11/3/2(水) 15:43 -
引用なし
パスワード
   ExlApp.Run ("'" & OPFL & "'!Auto_Open")　'Auto_Openの場合実行
　　　　　　　　　　　　　　　　　　　　　↑
　　Auto_Open")の後のスペースもタブに返還されているから。
・ツリー全体表示
【269】ワードの場合
全般  Jaka  - 11/3/2(水) 11:27 -
引用なし
パスワード
   ワードの場合はね。
ってほとんど変わってない。
掲示板上で、半角スペースがTabに返還されているところは同じ。
修正が必要。

Dim WsArg,WdApp

Set WsArg = WScript.Arguments
If WsArg.Count = 0 Then
　 WScript.Echo "このVbsファイルにWordファイルをドラッグ&ドロップしてください。"
　 Wscript.Quit
End If

'起動しているワード（アプリ）があるかチェック
On Error Resume Next
Set WdApp = GetObject(, "Word.Application" )
If WdApp Is Nothing Then
　 Set WdApp = CreateObject("Word.Application")
End If
On Error Goto 0

WdApp.Visible = True
WdApp.Documents.Open WsArg(0)
CreateObject("WScript.Shell").AppActivate WdApp.Caption
WdApp.WindowState = 0
Set WdApp = Nothing
Set WsArg = Nothing
Wscript.Quit
・ツリー全体表示
【268】VBSファイルにxlsファイルをドラッグ＆ドロ...
Excel  Jaka  - 11/3/1(火) 17:18 -
引用なし
パスワード
   下記コードが書かれたVBSファイルにエクセルブックをドラッグ＆ドロップすると
エクセルが起動してファイルを開いてくれます。
ただ、下記コードをメモ帳にコピペしても動かないかも。
改行コードの違いか文字コードの違いか解らないけど、以前ここにアップして
試した時は動いてくれなかった。

原因。
>　 MsgBox "このVbsファイルに画像ファイルをドラッグ&ドロップしてください。",
↑
この辺など他、半角スペースがタブに返還されているから...。
このタブを消すか半角スペースに直せば動きます。


Dim WsArg,ExlApp

Set WsArg = WScript.Arguments
If WsArg.Count = 0 Then
MsgBox "このVbsファイルにエクセルファイルをドラッグ&ドロップしてください。", vbInformation,"Ｗクリックエラー。"
Wscript.Quit
End If

'エクセルが起動しているかチェック。
On Error Resume Next
Set ExlApp = GetObject(, "Excel.Application" )
If ExlApp Is Nothing Then
'MsgBox "エクセルが起動していないようなので中止。", vbInformation,"エクセル起動エラー"
'Wscript.Quit
'↓エクセルが起動していなかった場合、起動させたい時。
Set ExlApp = CreateObject("Excel.Application")
End If
On Error Goto 0

OPFL = WsArg(0)
ExlApp.Visible = True
ExlApp.WorkBooks.Open OPFL

CreateObject("WScript.Shell").AppActivate ExlApp.Caption
ExlApp.WindowState = -4143

On Error Resume Next
ExlApp.Run ("'" & OPFL & "'!Auto_Open")　'Auto_Openの場合実行
On Error Goto 0

Set ExlApp = Nothing
・ツリー全体表示
【267】表に位置について。
Excel  Jaka  - 11/2/14(月) 16:59 -
引用なし
パスワード
   上記祝祭日表の位置が気に食わなかったら、１度下記セルに貼り付けてから、
列や行を削除するなり、移動させれば良いです。
参照先も自動で変更されます。

Ｂ１
Ｂ４〜Ｂ２９
Ｃ４〜Ｃ２９
・ツリー全体表示
【265】42歳のオジイさんですｗｗ
Access  ヨシカズ  - 10/3/25(木) 7:25 -
引用なし
パスワード
   俺みたいなオッサンのイチモツでも、喜んでくれる女性っているもんだな。
SEXの練習相手になっただけで6万円も頂いちゃったよ（＾＾）
・ツリー全体表示
【264】Re:ちょっと気になる現象6　Shapeオブジェ...
Excel  ichinose  - 10/2/11(木) 20:22 -
引用なし
パスワード
   >アクティブシートに二つの黒く塗りつぶされた見た目はまったく同じの
>オートシェイプの円があります。
>
>以下のような塗りつぶしの色が黒だったら、削除する　というコードを実行したところ
>
> Sub test1()
>　　Dim c As Shape
>　　For Each c In ActiveSheet.Shapes
>　　　 If c.Fill.ForeColor.SchemeColor = 8 Then c.Delete
>　　　'---------------------------------
>　　Next c
> End Sub

上記コードのエラーは、以下のコードで作成された二つのオートシェイプの円に対して
実行すると、発生します。

'=========================================================
Sub サンプル作成()
　　Dim ra As Range
　　Dim rc As Range
　　Set ra = Range("b2")
　　Set rc = Range("d2")
　　With ActiveSheet.Shapes.AddShape(msoShapeOval, ra.Left, ra.Top, ra.Width, ra.Width)
　　　 .Fill.ForeColor.SchemeColor = 8
　　End With
　　With ActiveSheet.Shapes.AddShape(msoShapeOval, rc.Left, rc.Top, rc.Width, rc.Width)
　　　 .Fill.ForeColor.RGB = RGB(0, 0, 0)
　　End With
End Sub

同じ黒でもSchemeColorで設定した円とRGB で設定した円、test1は、
RGBで設定した円に対してエラーが発生します。


サンプル作成で作成した円は、以下のコード（test2）だと正常に二つとも削除してくれます。

Sub test2()
　　Dim c As Shape
　　For Each c In ActiveSheet.Shapes
　　　 If c.Fill.ForeColor.RGB = 0 Then c.Delete
　　Next c
End Sub


又、DrawingobjectsのInterior.ColorやColorindexで判断すると
どちらでも(test3 は、Colorindexで判断、test4は、RGBで判断）削除してくれます。

'======================================================
Sub test3()
　　Dim c As Object
　　For Each c In ActiveSheet.DrawingObjects
　　　 If c.Interior.ColorIndex = 1 Then c.Delete
　　Next c
End Sub
'======================================================
Sub test4()
　　Dim c As Object
　　For Each c In ActiveSheet.DrawingObjects
　　　 If c.Interior.Color = 0 Then c.Delete
　　Next c
End Sub

こんなところでも古いオブジェクトのほうが安定しています。


ShapeのFill.ForeColor.RGB だと微妙な色の設定ができることは
認めますけどね！！


Sub サンプル作成3()
　　Dim ra As Range
　　Dim rc As Range
　　Set ra = Range("b2")
　　Set rc = Range("d2")
　　With ActiveSheet.Shapes.AddShape(msoShapeOval, ra.Left, ra.Top, ra.Width, ra.Width)
　　　 .Fill.ForeColor.RGB = RGB(220, 105, 235)
　　End With
　　With ActiveSheet.Ovals.Add(rc.Left, rc.Top, rc.Width, rc.Width)
　　　 .Interior.Color = RGB(220, 105, 235)
　　End With
End Sub
・ツリー全体表示
【263】ちょっと気になる現象6　Shapeオブジェクト...
Excel  ichinose  - 10/2/11(木) 19:21 -
引用なし
パスワード
   アクティブシートに二つの黒く塗りつぶされた見た目はまったく同じの
オートシェイプの円があります。

以下のような塗りつぶしの色が黒だったら、削除する　というコードを実行したところ

Sub test1()
　　Dim c As Shape
　　For Each c In ActiveSheet.Shapes
　　　 If c.Fill.ForeColor.SchemeColor = 8 Then c.Delete
　　　'---------------------------------
　　Next c
End Sub

一つの円は、正常に削除されましたが、もう一つの円のでは、
「実行時エラー　70　書き込みできません。」というエラーが発生し、　
上記の----の部分が黄色に塗りつぶされました。
　

どんな原因が考えられるでしょうか？
・ツリー全体表示
【262】Re:ユーザー定義型は定義されていません の...
全般  Jaka  - 10/1/27(水) 11:04 -
引用なし
パスワード
   上の方に書いてある↓をよく読んでください。

●「目安箱」は質問禁止です。技術的な質問はそれぞれの質問箱へどうぞ。

>　　Dim ws As worksheeet
　　　　　　　　　　 ↑
　　　　　　　　　 ？？？
・ツリー全体表示
【261】ユーザー定義型は定義されていません の対処
Excel  KN  - 10/1/27(水) 10:49 -
引用なし
パスワード
   以下の、マクロを書いたのですが、いろいろなところで、「ユーザー定義型は定義されていません」と表示されてしまい、そもそもかいたものがちゃんと動くかどうかも検証できません。

全くの初心者ゆえこのような漠然とした質問が許されるとも思ってはおりませんが、まったくどうしたらいいかわからず、幼稚な質問をあげることお許しください。

アドバイスをいただければ幸いです。よろしくお願いします。

Sub makingcollection()
'【格納パート】
'とりあえず全てのシートの注文番号がついているものを配列に、
'注文内容、取引先、納期、金額の順に格納する


　　Dim vList() As String
　　Dim c As Long
　　Dim d As Long
　　Dim m As Long
　　Dim ws As worksheeet
　　Dim chck As String
　　c = 0
　　
For Each ws In Worksheet
　　m = ws.Range("B65536").End(xlUp).Value
　　For d = 16 To m
　　　　ws.Range("b" & d).Value = chck
　　　　If chck <> "" And Left(chck, 1) <> "（" Then '空白かカッコで始まる場合無視
　　　　　　ReDim Preserve st(c)
　　　　　　vList(0, c) = ws.Range("B" & d).Value
　　　　　　vList(1, c) = ws.Range("C" & d).Value
　　　　　　vList(2, c) = ws.Range("D" & d).Value
　　　　　　vList(3, c) = ws.Range("E" & d).Value
　　　　　　vList(4, c) = ws.Range("G" & d).Value
　　　　　　c = c + 1
　　　　End If
　　Next

Next

'【出力パート】
'フォーマットつくり
　　Worksheets.Add.Name = "総括"
　　
　　Range("A1").Value = "注文番号"
　　Range("B1").Value = "注文内容"
　　Range("C1").Value = "取引先名称"
　　Range("D1").Value = "納期"
　　Range("E1").Value = "発注金額"

'出力
　　Dim cx As Long
　　
　　For cx = LBound(st, 2) To UBound(st, 2)
　　　　Range("A" & cx + 1).Value = vList(0, cx)
　　　　Range("B" & cx + 1).Value = vList(1, cx)
　　　　Range("C" & cx + 1).Value = vList(2, cx)
　　　　Range("D" & cx + 1).Value = vList(3, cx)
　　　　Range("E" & cx + 1).Value = vList(4, cx)
　　Next
　　
End Sub
・ツリー全体表示
【260】Re:オートフィルタについて
Excel  ponpon  - 10/1/8(金) 13:45 -
引用なし
パスワード
   いっぱいミスがありました。

Sub test()
　Dim A()
　Dim i As Long
　Dim x As Long
With Sheets("Sheet1")
　　For i = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
　
　　　 If Val(Right(.Cells(i, "A").Value, 1)) Mod 2 = 0 Then
　　　　 ReDim Preserve A(x)
　　　　 A(x) = .Cells(i, "A").Value
　　　　　x = x + 1
　　　 End If
　　Next
End With
With Sheets("Sheet2")
　　 .Range("A1").Resize(UBound(A()) + 1).Value = Application.Transpose(A())
End With
End Sub
・ツリー全体表示
【259】Re:オートフィルタについて
Excel  ｍｍ  - 10/1/8(金) 12:45 -
引用なし
パスワード
   ▼ponpon さん：

あーーすみません
気づかなかったです
質問はここでは禁止だったんですね。

申し訳ございませんでした

でも、アドバイスありがとうございます

解読してみます
・ツリー全体表示
【258】Re:オートフィルタについて
Excel  ponpon  - 10/1/8(金) 11:34 -
引用なし
パスワード
   ここでは、質問はできませんので
EXCEL質問箱の方へどうぞ。

オートフィルタでは、私の力ではできませんが、
別シートに書き出すなら
こんな感じで・・

Sub test()
　Dim A()
　Dim i As Long
　Dim x As Long
With Sheets("Sheet1")
　　For i = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
　　　
　　　 If Val(Right(.Cells(i, "A").Value, 1)) Mod 2 = 0 Then
　　　　 ReDim Preserve A(i)
　　　　 A(j) = .Cells(i, "A").Value
　　　　　j = j + 1
　　　 End If
　　Next
End With
With Sheets("Sheet2")
　　 .Range("A1").Resize(UBound(A()) - 1).Value = Application.Transpose(A())
End With
End Sub
・ツリー全体表示
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃ホーム  
2 / 14 ﾍﾟｰｼﾞ ←次へ　｜　前へ→
ページ：  ┃  記事番号：   
0
(SS)C-BOARD v3.8 is Free