目安箱 IV

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

迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃ホーム  
1 / 14 ページ 前へ→

【288】Re:二次元配列の合体
Excel  マナ  - 17/9/3(日) 21:11 -

引用なし
パスワード
   ▼Jaka さん:

>しょぼい。

そんなことないです。
わたしは大きなデータを使うことないので、全く問題なさそうです。
勉強になりました。

1000行×10列:<0,1sec
10000行×10列:<1sec
60000行×10列:<4sec

1000行×26列:<0,5sec
10000行×26列:<4sec
60000行×26列:<20sec

Sub test()
  Dim TBL_1, TBL_2
  
  ActiveSheet.UsedRange.ClearContents
  
  TBL_1 = [row(a1:a100)*column(a1:z1)]
  TBL_2 = [row(a1:a10000)&"_"&column(a1:z1)]
  
  MsgBox "2つの配列を合体します。"
 
  Dim t As Double
  t = Timer
  
  Dim tbb()
  ReDim tbb(1 To UBound(TBL_1, 2))
  Dim NewTB
  Dim i As Long, 行 As Long, 列 As Long
   
  For i = 1 To UBound(tbb)
    tbb(i) = Split(Join(Application.Transpose(Application.Index(TBL_1, 0, i))) & " " & _
        Join(Application.Transpose(Application.Index(TBL_2, 0, i))))
  Next
  
  NewTB = Application.Transpose(tbb)
  
  MsgBox Timer - t
  
  行 = UBound(NewTB, 1)
  列 = UBound(NewTB, 2)
   Cells(1).Resize(行, 列).Value = NewTB
  
  Erase TBL_1, TBL_2, tbb, NewTB

End Sub
・ツリー全体表示

【287】ちょい変更
Excel  Jaka  - 17/9/1(金) 23:39 -

引用なし
パスワード
   > Dim tbb(1 To 4)
> Dim NewTB()

 ↓

Dim tbb()
Dim NewTB()
ReDim tbb(1 To UBound(TBL_1, 2))
・ツリー全体表示

【286】二次元配列の合体
Excel  Jaka  - 17/9/1(金) 22:46 -

引用なし
パスワード
   使用頻度はほとんど無いと思うけど、なんとなく勉強のために。
なんかやたら、メモリ喰いそうだし。
シートに貼り付けて合体させた方が速そう。

エクセル関数を使っているので要素数の上限問題が…。
Excel2000だと、Transposeできる配列の要素数は、5461個(1〜5461)まで。
つまり、Excel2000だと2つの配列の総素数の合計が、5461個までしかまともに動かないと思う。

10カラム(10列)づつだったら、合計546行ぐらいか。
しょぼい。
見本(下記コードで作った)以外のデータでは試していません。

尚、メインのThinkpad A31(Win2000 & Excel2000)のバッテリーが逝かれて、
起動するとバイオス画面が出てくるようになったので、
下記コードは、Win7 & Excel2007 で書きました。


Sub 二次元配列合体()
 Dim TBL_1(1 To 4, 1 To 4)
 Dim TBL_2(1 To 3, 1 To 4)

 Range("A1:E20").Value = Empty

 '二次元配列に値を代入(ショボイデータ作成)
 TBL_1(1, 1) = 11: TBL_1(1, 2) = 12: TBL_1(1, 3) = 13: TBL_1(1, 4) = 14
 TBL_1(2, 1) = 21: TBL_1(2, 2) = 22: TBL_1(2, 3) = 23: TBL_1(2, 4) = 24
 TBL_1(3, 1) = 31: TBL_1(3, 2) = 32: TBL_1(3, 3) = 33: TBL_1(3, 4) = 34
 TBL_1(4, 1) = 41: TBL_1(4, 2) = 42: TBL_1(4, 3) = 43: TBL_1(4, 4) = 44
 Range("A1:D4").Value = TBL_1

 TBL_2(1, 1) = "A1": TBL_2(1, 2) = "B1": TBL_2(1, 3) = "C1": TBL_2(1, 4) = "D1"
 TBL_2(2, 1) = "A2": TBL_2(2, 2) = "B2": TBL_2(2, 3) = "C2": TBL_2(2, 4) = "D2"
 TBL_2(3, 1) = "A3": TBL_2(3, 2) = "B3": TBL_2(3, 3) = "C3": TBL_2(3, 4) = "D3"
 Range("A6:D8").Value = TBL_2

 MsgBox "シートに書いた2つの配列を合体します。"

 '列数分の配列を作り、二次元配列から1列づつ一次元配列に変換した配列を収めていく。
 '二次元配列から1列転記した場合、二次元配列になっていたので。

 Dim tbb(1 To 4)
 Dim NewTB()

 For i = 1 To UBound(tbb)
   tbb(i) = Split(Join(Application.Transpose(Application.Index(TBL_1, 0, i))) & " " & _
          Join(Application.Transpose(Application.Index(TBL_2, 0, i))))
 Next

 NewTB = Application.Transpose(tbb)
 行 = UBound(NewTB, 1)
 列 = UBound(NewTB, 2)
 Range("A11").Resize(行, 列).Value = NewTB

 Erase TBL_1, TBL_2, tbb, NewTB
End Sub
・ツリー全体表示

【285】抽出先でデータ編集をして抽出元に反映させ...
Excel  ぴぐもん  - 17/8/12(土) 19:07 -

引用なし
パスワード
   ”リスト”シートにはA1〜G1が項目、A2〜G2からデータがあります。
”検索”シートに条件を入力し検索ボタンを入力すれば一致するデータが表示されます。A1〜G1項目、A2〜G2が検索条件、A4〜G4が結果表示用項目
A5〜G5が抽出結果表示欄(複数あれば続けてA6〜〇5で表示)
抽出結果を修正し、反映ボタンを押せば”リスト”シートが更新される。

このようなマクロボタンを作りたいと考えています。

Sub 正方形長方形2_Click()
Sheets("検索").Rows("4:65536").ClearContents
  Sheets("リスト").Select
  Range("A2").Select
  ActiveCell.CurrentRegion.AdvancedFilter _
   Action:=xlFilterCopy, _
   CriteriaRange:=Sheets("検索").Range("A1:E2"), _
   CopyToRange:=Sheets("検索").Range("A5:E65536"), _
   Unique:=False
  Sheets("検索").Select
End Sub
これで抽出はうまくいくのですが、反映する際、
Dim cel As Range
If IsNumeric(Range("A5").Value) And Not IsEmpty(Range("A5").Value) Then
     Worksheets("リスト").Cells(Range("A5").Value, 1).Resize(1, 26).Value _
       = Range("A5:Z5").Value
   Else
     MsgBox "行番号が??です"
   End If

これですると”リスト”シートが乱れてしまいます。
ご教授願います。
・ツリー全体表示

【284】Re:今更ながら。
Access  ヒラタ  - 17/6/14(水) 3:03 -

引用なし
パスワード
   ▼Jaka さん:
>誤字だらけやん。
>10年たってから気づきました。
>すみません。
>他にもありそうな気が・・・。
>
>>  PtWd = InputBox("ボタンに持たせる引数(数字のみ)を入力してください。", "引数入力", , XPos:=横位置, YPos:=縦位置)
>>  If PtWd = "" Then
>>    MsgBox "引数なし 終了"
>>    Exit Sub
>>  ElseIf Not IsNumeric(PasWd) Then
>>    MsgBox "数字だけです。 終了"
>>    Exit Sub
>>  End If
> 
>
>ElseIf Not IsNumeric(PasWd) Then
>  ↓
>ElseIf Not IsNumeric(PtWd) Then


ご情報ありがとうございます。


yaplog.jp/hotbags/
・ツリー全体表示

【283】dowhileで複数条件を指定
Excel  山川  - 16/10/23(日) 14:03 -

引用なし
パスワード
   dowhileで複数条件を指定をしても、効きません。

Do While Ws.Cells(I, 5).Value = False And UsrFrmQus.txtFil.Text <> Ws.Cells(I, 1).Value

dowhileではもともと複数条件指定できないのですか?
・ツリー全体表示

【282】入力規則リストにない値が入力できてしまう...
Excel  nanashi  - 15/8/12(水) 11:57 -

引用なし
パスワード
   リストによる入力規則で、「何も選ばない」を可能にするためリスト範囲の先頭に空白セルを含める場合がある。

この時、リスト範囲を入力規則を設定したセルと異なるワークシートにある名前で指定すると、エラー設定をしているにもかかわらず任意の値が入力できてしまう。
Excel 95-2003 形式では他のシートを直接参照する入力規則は利用できなかったため、名前で指定することが多かった。

エラー設定を有効にするには、Excel 2007 以降で =SheetName!Address と指定するか =INDIRECT("範囲の名前") とすればよい。
・ツリー全体表示

【281】今更ながら。
Excel  Jaka  - 15/8/6(木) 12:25 -

引用なし
パスワード
   誤字だらけやん。
10年たってから気づきました。
すみません。
他にもありそうな気が・・・。

>  PtWd = InputBox("ボタンに持たせる引数(数字のみ)を入力してください。", "引数入力", , XPos:=横位置, YPos:=縦位置)
>  If PtWd = "" Then
>    MsgBox "引数なし 終了"
>    Exit Sub
>  ElseIf Not IsNumeric(PasWd) Then
>    MsgBox "数字だけです。 終了"
>    Exit Sub
>  End If


ElseIf Not IsNumeric(PasWd) Then
  ↓
ElseIf Not IsNumeric(PtWd) Then
・ツリー全体表示

【280】両隣のセルにコピーする
Excel  ショウ E-MAIL  - 15/8/1(土) 16:20 -

引用なし
パスワード
   困っています。

VBAで変化させたい表は以下のようになっています。
C   X Y Z
    2 4 4
    3 5 5
計   5 9 3   
    
空欄のC列に計と入力がある場合、計が入力されている同行のX列とZ列のセルに、真ん中のY列にある数字が入力されるようにしたいです。上の場合だと9が両隣に5にコピーされるようにしたいです。
また、この処理を450行目まで繰り返し行えるようにしたいです。

ちなみに考えたVBAは
Sub ()

If Cells(i, "C").Value = "小計(kg)" Then
Cells(i, "X").Value = Cells(i, "Y").Value
Cells(i, "Z").Value = Cells(i, "Y").Value

For i = 1 To 450
Next i
End if
End Sub

このまま起動させると、アプリケーションの定義またはオブジェクションの定義のエラーとなります.

どのように書き換えれば良いでしょうか?
宜しくお願いします。
・ツリー全体表示

【279】accessのパフォーマンスの最適化について
Access  マサリン  - 15/3/6(金) 22:56 -

引用なし
パスワード
   access 2010のパフォーマンスの最適化について教えてください。
パフォーマンスの最適化のフォームを解析中、このプロパティの設定値が値が長すぎます。のエラーが表示されます。
このエラーの解消抱負を教えてください。
・ツリー全体表示

【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を参照して同じサービス書番号のテーブルB2つのフィールドをテーブル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】動かない原因2.
全般  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
・ツリー全体表示

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃ホーム  
1 / 14 ページ 前へ→
ページ:  ┃  記事番号:   
0
(SS)C-BOARD v3.8 is Free