Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
105 / 3841 ﾍﾟｰｼﾞ ←次へ　｜　前へ→
【80382】ワークシートをコピーし空白行を削除した...
質問  nonchan E-MAIL  - 19/2/6(水) 17:25 -
引用なし
パスワード
   初めて質問します。VBA初心者です。

【やりたい事】
ワークシート「ﾃﾝﾌﾟﾚｰﾄ」をコピーし、「WBSﾘｽﾄ」にある名前をワークシート名に
して、空白行を削除した後、「WBSﾘｽﾄ」にある全部の名前のワークシートを作成
する。

【やってみた事】
1.ワークシート「ﾃﾝﾌﾟﾚｰﾄ」をコピーし、「WBSﾘｽﾄ」にある名前をワークシート名に
　して、「WBSﾘｽﾄ」にある全部の名前のワークシートを作成する。
　　　　　↓
Sub 経費予算資料作成()
　　Application.ScreenUpdating = False
　　
　　Dim i As Long
　　For i = 2 To Sheets("WBSﾘｽﾄ").Cells(Rows.Count, "A").End(xlUp).Row
　　　　Sheets("ﾃﾝﾌﾟﾚｰﾄ").Copy after:=Sheets(Sheets.Count)
　　　　ActiveSheet.Name = Sheets("WBSﾘｽﾄ").Cells(i, "A")
　　　　Range("A1") = Sheets("WBSﾘｽﾄ").Cells(i, "A")
　　Next i

End Sub
　　　　　↓
これは上手くいきました。

2.アクティブなワークシートの空白行を削除する。
　　　　　↓
Sub test空白行を削除する()
　　Application.ScreenUpdating = False
　　
　　Dim j As Long
　　For j = 630 To 2 Step -1
　　　　If Range("R" & j).Value = "空白行" Then
　　　　　　Rows(j).Select
　　　　　　Selection.Delete shift:=xlUp
　　　　End If
　　Next j
End Sub
　　　　　↓
これも上手くいきました。

3.　1.+2.ワークシートを作成したら、空白行を削除して
　次のワークシートを作成する。
　　　　　↓
Sub test経費予算資料作成空白行削除()
　　Application.ScreenUpdating = False
　　
　　Dim i As Long
　　For i = 2 To Sheets("WBSﾘｽﾄ").Cells(Rows.Count, "A").End(xlUp).Row
　　　　Sheets("ﾃﾝﾌﾟﾚｰﾄ").Copy after:=Sheets(Sheets.Count)
　　　　ActiveSheet.Name = Sheets("WBSﾘｽﾄ").Cells(i, "A")
　　　　Range("A1") = Sheets("WBSﾘｽﾄ").Cells(i, "A")
　　　　
　　　　　　Dim j As Long
　　　　　　For j = 630 To 2 Step -1
　　　　　　　　　If Range("R" & j).Value = "空白行" Then
　　　　　　　　　　 Rows(j).Select
　　　　　　　　　　Selection.Delete shift:=xlUp
　　　　　　End If
　　　　Next j
　　　
　　Next i
End Sub
　　　　↓
失敗しました！！

1.と2.を合体させることができません。
3.のプロシージャの訂正、或いは何かいい方法はないでしょうか。

よろしくお願いいたします。
以上　
・ツリー全体表示
【80381】Re:時間の足し算を行うと、yyyy/mm/dd h...
発言  マナ  - 19/2/5(火) 20:32 -
引用なし
パスワード
   ▼amatsuno さん：
　　　　　　　　　　
>
>また、出力先の列を変更する場合、
>（ここでは、1・2列目に出しているものを、1・3列目にしたい）
>はどこを変えればよいのでしょうか？


With .Range("A1").Resize(dic2.Count)
　　.EntireColumn.ClearContents
　　.Value = Application.Transpose(dic2.Keys)
End With
With .Range("C1").Resize(dic2.Count)
　　.EntireColumn.ClearContents
　　.Value = Application.Transpose(dic2.items)
　　.NumberFormatLocal = "h:mm:ss"
End With
・ツリー全体表示
【80380】Re:カレンダーに予定を自動入力したい
発言  マナ  - 19/2/5(火) 19:47 -
引用なし
パスワード
   ▼VBA初心者 さん：

>↑の部分で検索していると思っていましたが、違いますでしょうか・・・？

そうなのですが、検索できなかったはずでは？
今は検索できていても、いつかまた検索できないとなる場合もあるはずです。
そのときは、γさんの回答を参考にしてください。
実際に経験すると理解できるかと思いますので
わたしからは修正案は提示しません。

-----
で、複数シートの検索の件ですが、
日付から、何月のシートを検索すればよいかわかるはずです。
すべてシートを検索する必要はないという意味です。


　
・ツリー全体表示
【80379】Re:時間の足し算を行うと、yyyy/mm/dd h...
発言  マナ  - 19/2/5(火) 18:30 -
引用なし
パスワード
   ▼amatsuno さん：
　　　　　　　
>TEST,　　　　15,　　　　USR3,　　　　8:41:14　　　　　　　　　　　　
>TEST,　　　　15,　　　　USR3,　　　　5:41:03　　　　　　　　　　　　
>TEST,　　　　15,　　　　USR3,　　　　0:28:32　　　　　　　　　　　　
>TEST,　　　　15,　　　　USR3,　　　　2:26:55　　　　　　　　　　　　
　　　　　　　　　　　
>　
> 上記を実行したとき、出力先のカラム2の値がyyyy/mm/dd h/mm/ss表記(カラム2が15の列　⇒ 1900/1/4　15:18:37)
> となり、また、合計値が正常でない値（01:17:44と出る予定）が出力されてしまいます


17:17:44となりますが？
・ツリー全体表示
【80378】時間の足し算を行うと、yyyy/mm/dd h/mm...
質問  amatsuno E-MAIL  - 19/2/5(火) 15:17 -
引用なし
パスワード
   excel上で時間表記されているカラムの足し算を行うと、
足し算の結果セルがyyyy/mm/dd h/mm/ss表記になってしまいました。

また、足し算の合計値が想定と違う結果になってしまいます

元excelのシート
TEST,　　　　1,　　　　TEST,　　　　3577:00:59　　　　　　　　
TEST,　　　　3,　　　　USR2,　　　　3330:25:19　　　　　　　　
TEST,　　　　3,　　　　USR2,　　　　3381:50:06　　　　　　　　
TEST,　　　　15,　　　　USR3,　　　　8:41:14　　　　　　　　　　　　
TEST,　　　　15,　　　　USR3,　　　　5:41:03　　　　　　　　　　　　
TEST,　　　　15,　　　　USR3,　　　　0:28:32　　　　　　　　　　　　
TEST,　　　　15,　　　　USR3,　　　　2:26:55　　　　　　　　　　　　
TEST,　　　　18,　　　　USR3,　　　　10:14:12　　　　　　　　
TEST,　　　　18,　　　　USR3,　　　　5:17:49　　　　　　　　　　　　
TEST,　　　　18,　　　　USR3,　　　　0:22:22　　　　　　　　　　　　
TEST,　　　　18,　　　　USR3,　　　　3:30:58　　　　　　　　　　　　
TEST,　　　　19,　　　　USR4,　　　　0:46:43　　　　　　　　　　　　
TEST,　　　　19,　　　　USR4,　　　　0:39:59　　　　　　　　　　　　
TEST,　　　　19,　　　　USR4,　　　　3:33:07　　　　　　　　　　　　
TEST,　　　　19,　　　　USR4,　　　　3:36:23　　　　　　　　　　　　
TEST,　　　　19,　　　　USR4,　　　　0:59:02　　　　　　　　　　　　
TEST,　　　　19,　　　　USR4,　　　　0:31:00　　　　　　　　　　　　


上記の状態で、カラム2が同一の番号の時間（カラム4）を合計しようとしています。


With Worksheets("元")
　　　For i3 = 2 To .Cells(Rows.Count, "B").End(xlUp).Row
　　　　 vK2 = .Cells(i3, "B").Value
　　　　 dic2(vK2) = dic2(vK2) + .Cells(i3, "D")
　　　Next
　 End With

　 ReDim vA3(1 To dic2.Count, 1 To 2)
　 i3 = 0
　 For Each vK2 In dic2.Keys
　　　i3 = i3 + 1
　　　vA3(i3, 1) = vK2
　　　vA3(i3, 2) = dic2(vK2)
　 Next

　 Application.ScreenUpdating = False
　 With Worksheets("出力先")
　　　With .Range("A1").Resize(i3, 2)
　　　　 .EntireColumn.ClearContents
　　　　 .Value = vA3
　　　　 .Columns(2).NumberFormatLocal = "h:mm:ss"
　　　　 .Columns(4).NumberFormatLocal = "h:mm:ss"
　　　　 Application.Goto .Cells(1), True
　　　End With
　 End With
　 Application.ScreenUpdating = True

　 Rows(1).Insert
　
上記を実行したとき、出力先のカラム2の値がyyyy/mm/dd h/mm/ss表記(カラム2が15の列　⇒ 1900/1/4　15:18:37)
となり、また、合計値が正常でない値（01:17:44と出る予定）が出力されてしまいます


上記コードのどこが誤っているのでしょうか？
お分かりになられる方、よろしくお願いいたします


また、出力先の列を変更する場合、
（ここでは、1・2列目に出しているものを、1・3列目にしたい）
はどこを変えればよいのでしょうか？
・ツリー全体表示
【80377】:ForーNext
お礼  トキノハジメ  - 19/2/5(火) 9:29 -
引用なし
パスワード
   ▼マナ さん：よろずや　さん

ありがとう御座いました。

大変プログラムが短くなりました。

これからもよろしくお願いいたします。
・ツリー全体表示
【80376】Re:カレンダーに予定を自動入力したい
お礼  VBA初心者  - 19/2/5(火) 9:23 -
引用なし
パスワード
   ▼マナ さん：
>▼VBA初心者 さん：
>
>>追加でご質問させていただいてもよろしいでしょうか？
>
>そのまえに、わたしの提示したマクロでは検索できていませんよね。
>それでもよいのですか？

マナ様

お返事ありがとうございます。
Set rng検索 = rngカレンダー.Find(c.Value, LookAt:=xlWhole)
　　　　
　　　　If Not rng検索 Is Nothing Then
　　　　　　With rng検索.Offset(1, 0)
　　　　　　　　業務 = WorksheetFunction.Trim(c.Offset(0, 1).Value & " " & .Value)

↑の部分で検索していると思っていましたが、違いますでしょうか・・・？
・ツリー全体表示
【80375】Re:カレンダーに予定を自動入力したい
お礼  VBA初心者  - 19/2/5(火) 9:10 -
引用なし
パスワード
   ▼γ さん：
>ああ、そうでしたか、
>質問者さんの「できない」を信用してしまったのですが、
>LookIn:=xlValuesをLookIn:=xlFormulas　にすれば
>日ではなくそんままの値を検索値にして、
>ユニークに特定でき、二度調べる必要はなかったのですね。
>不覚・・・。
>

γ様
お返事ありがとうございます。
教えていただいたことを参考に、自分でもう一度調べながらやってみようと思います！
本当にありがとうございました！
・ツリー全体表示
【80374】Re:ForーNext
回答  よろずや  - 19/2/4(月) 22:23 -
引用なし
パスワード
   横レスです

　　　　.AutoFilter Field:=1. Criteria1:="8"
　　　　　　　　　　　　　 ↓
　　　　.AutoFilter Field:=1, Criteria1:="8"
・ツリー全体表示
【80373】Re:ForーNext
質問  トキノハジメ  - 19/2/4(月) 22:09 -
引用なし
パスワード
   ▼マナ さん：
>▼トキノハジメ さん：
>
>こうでしょうか
>
>Sub test()
>　　Dim k As Long
>
>　　For k = 0 To 4
>　　　　Cells(12 + k * 20, "AU").Resize(18).Copy
>　　　　Cells(12 + k, "C").PasteSpecial Paste:=xlValues, Transpose:=True
>　　Next
>
>
>　　With Range("BL11").CurrentRegion
>　　　　.AutoFilter Field:=1. Criteria1:="8"
>　　
>　　　　For k = 0 To 5
>　　　　　　.AutoFilter Field:=2, Criteria1:=k + 1
>　　　　　　.Copy Range("BE" & 11 + k * 20)
>　　　　Next
>　　　　.AutoFilter
>　　End With
>　　
>End Sub

早速の回答有り難う御座います。

Criteria1　のところで文字が赤くなってしまうのですが、
打ち込み間違いはないと思うのですが
宜しくおねがいいたします。
・ツリー全体表示
【80372】Re:ForーNext
発言  マナ  - 19/2/4(月) 19:14 -
引用なし
パスワード
   ▼トキノハジメ さん：

こうでしょうか

Sub test()
　　Dim k As Long

　　For k = 0 To 4
　　　　Cells(12 + k * 20, "AU").Resize(18).Copy
　　　　Cells(12 + k, "C").PasteSpecial Paste:=xlValues, Transpose:=True
　　Next


　　With Range("BL11").CurrentRegion
　　　　.AutoFilter Field:=1. Criteria1:="8"
　　
　　　　For k = 0 To 5
　　　　　　.AutoFilter Field:=2, Criteria1:=k + 1
　　　　　　.Copy Range("BE" & 11 + k * 20)
　　　　Next
　　　　.AutoFilter
　　End With
　　
End Sub
・ツリー全体表示
【80371】ForーNext
質問  トキノハジメ  - 19/2/4(月) 18:39 -
引用なし
パスワード
   いつもお世話になります。

下記のコードをFor−Nextにするにわうどすればよいのでしょうか。

Range("AU12:AU29").Copy
Range("C12:T12").PasteSpecial , Passte:=xlValues, Transpose:=True
Range("AU32:AU49").Copy
Range("C13:T13").PasteSpecial , Passte:=xlValues, Transpose:=True
Range("AU52:AU69").Copy
Range("C14:T14").PasteSpecial , Passte:=xlValues, Transpose:=True
Range("AU72:AU89").Copy
Range("C15:T15").PasteSpecial , Passte:=xlValues, Transpose:=True
Range("AU92:AU109").Copy
Range("C16:T16").PasteSpecial , Passte:=xlValues, Transpose:=True


With Range("BL11")
　　.AutoFilter Field:=1. Criteria1:="8"
　　.AutoFilter Field:=2. Criteria1:="1"
　　.CurrentRegion.Copy Range("BE11")
　　.AutoFilter
End Witu
With Range("BL11")
　　.AutoFilter Field:=1. Criteria1:="8"
　　.AutoFilter Field:=2. Criteria1:="2"
　　.CurrentRegion.Copy Range("BE31")
　　.AutoFilter
End Witu

With Range("BL11")
　　.AutoFilter Field:=1. Criteria1:="8"
　　.AutoFilter Field:=2. Criteria1:="3"
　　.CurrentRegion.Copy Range("BE51")
　　.AutoFilter
End Witu

With Range("BL11")
　　.AutoFilter Field:=1. Criteria1:="8"
　　.AutoFilter Field:=2. Criteria1:="4"
　　.CurrentRegion.Copy Range("BE71")
　　.AutoFilter
End Witu

With Range("BL11")
　　.AutoFilter Field:=1. Criteria1:="8"
　　.AutoFilter Field:=2. Criteria1:="5"
　　.CurrentRegion.Copy Range("BE91")
　　.AutoFilter
End Witu

以上２組ですが、教えて下さい。
宜しくお願い致します。
・ツリー全体表示
【80370】Re:EXCELのユーザーフォームにあるリスト...
お礼  くるみ  - 19/2/3(日) 3:31 -
引用なし
パスワード
   データベースに別項目で状態を準備し、それによってリストボックスの内容を変えました。
ご指導いただきありがとうございました。
・ツリー全体表示
【80369】Re:カレンダーに予定を自動入力したい
発言  γ  - 19/2/2(土) 13:30 -
引用なし
パスワード
   ああ、そうでしたか、
質問者さんの「できない」を信用してしまったのですが、
LookIn:=xlValuesをLookIn:=xlFormulas　にすれば
日ではなくそんままの値を検索値にして、
ユニークに特定でき、二度調べる必要はなかったのですね。
不覚・・・。
・ツリー全体表示
【80368】Re:ListView：行がどんどん増えてしまう
お礼  愛沢  - 19/2/1(金) 23:59 -
引用なし
パスワード
   マナ様
ありがとうございます、愛沢です。

急な出張でマクロが弄れずお礼が遅くなった事をお詫びいたします。


>Private Sub ListView1_ItemClick(ByVal Item As MSComctlLib.ListItem)
>　　No = Item
>　　名前 = Item.SubItems(1)
>　　Call 団員登録表示処理
>　　団員登録.Show
>　　Item = No
>　　Item.SubItems(1) = 名前
>End Sub

に変えた所、引数は省略できません。で怒られました

Private Sub CommandButton3_Click()
　　Call 団員登録更新処理
End Sub

コールで作成するのはもっと勉強してからにして今回はコールを使わずに作成してみようかと思います。

貴重なお時間ありがとうございました。
・ツリー全体表示
【80367】Re:vba詳しい方、お力貸してください
発言  マナ  - 19/2/1(金) 22:14 -
引用なし
パスワード
   ▼ミリヤ さん：

>一人分だけならうまくいきました！！！

コードを理解できていますか？
ちょっと違いますが、このあたりを参考になります。
ht　tps://www.moug.net/tech/exvba/0060003.html
・ツリー全体表示
【80366】Re:カレンダーに予定を自動入力したい
発言  マナ  - 19/2/1(金) 22:00 -
引用なし
パスワード
   ▼VBA初心者 さん：

>追加でご質問させていただいてもよろしいでしょうか？

そのまえに、わたしの提示したマクロでは検索できていませんよね。
それでもよいのですか？
・ツリー全体表示
【80365】Re:vba詳しい方、お力貸してください
発言  ミリヤ  - 19/2/1(金) 16:36 -
引用なし
パスワード
   ▼マナ さん：
一人分だけならうまくいきました！！！
これを複数ファイルにおこないたいのですが。。
何かいい方法はないでしょうか。
・ツリー全体表示
【80364】Re:カレンダーに予定を自動入力したい
発言  γ  - 19/2/1(金) 11:59 -
引用なし
パスワード
   カレンダには日付データが、日を表示するだけの形式でセットされているとの前提です。
straightforwardに、こんなコードではどうでしょうか。

Sub カレンダー入力2()
　　Dim ws　　　　　As Worksheet
　　Dim lastRow　　 As Long　　
　　Dim rngCalendar As Range　　
　　Dim rngFound　　As Range　
　　Dim d　　　　　 As Long
　　Dim s　　　　　 As String
　　Dim k　　　　　 As Long

　　Set ws = Worksheets("Sheet1")
　　lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
　　Set rngCalendar = ws.Range("E1:K10")

　　For k = 1 To lastRow
　　　　d = ws.Cells(k, "A").Value　'日付け
　　　　s = ws.Cells(k, "B").Value　'スケジュール
　　　　Set rngFound = rngCalendar.find(Day(d), After:=rngCalendar(1), _
　　　　　　LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
　　　　　　MatchCase:=False, MatchByte:=False, SearchFormat:=False)
　　　　
　　　　'日でマッチさせると、たかだか2回マッチするだけなのでDo Loopは不要?
　　　　If d = rngFound.Value Then
　　　　　　Call setSchedule(rngFound.Offset(1, 0), s)
　　　　Else
　　　　　　Set rngFound = rngCalendar.FindNext(rngFound)
　　　　　　If Not rngFound Is Nothing Then
　　　　　　　　If d = rngFound.Value Then
　　　　　　　　　　Call setSchedule(rngFound.Offset(1, 0), s)
　　　　　　　　End If
　　　　　　End If
　　　　End If
　　Next
End Sub
Function setSchedule(r As Range, s As String)
　　If r.Value = "" Then
　　　　r.Value = s
　　Else
　　　　r.Value = r.Value & vbLf & s
　　End If
End Function
・ツリー全体表示
【80363】Re:カレンダーに予定を自動入力したい
質問  VBA初心者  - 19/2/1(金) 11:48 -
引用なし
パスワード
   ▼マナ さん：
>▼VBA初心者 さん：
>
>こんな感じのことでしょうか
>
>Option Explicit
>
>Sub カレンダー入力()
>　　Dim rngカレンダー As Range
>　　Dim rng予定表 As Range
>　　Dim c As Range
>　　Dim rng検索 As Range
>　　Dim 業務 As String
>　　
>　　Set rngカレンダー = Worksheets("Sheet2").Range("E1:K10")
>　　Set rng予定表 = Worksheets("Sheet1").Range("A1").CurrentRegion
>　　
>　　For Each c In rng予定表.Columns(1).Cells
>
>　　　　Set rng検索 = rngカレンダー.Find(c.Value, LookAt:=xlWhole)
>　　　　
>　　　　If Not rng検索 Is Nothing Then
>　　　　　　With rng検索.Offset(1, 0)
>　　　　　　　　業務 = WorksheetFunction.Trim(c.Offset(0, 1).Value & " " & .Value)
>　　　　　　　　.Value = Join(Split(業務), vbLf)
>　　　　　　End With
>　　　　End If
>　　　　
>　　Next c
>　　
>End Sub
>
>
>　
マナ様

先のご返答に引き続きありがとうございます。
とても参考になります。

追加でご質問させていただいてもよろしいでしょうか？

Set rngカレンダー = Worksheets("Sheet2").Range("E1:K10")
Set rng予定表 = Worksheets("Sheet1").Range("A1").CurrentRegion

↑の部分で

rngカレンダーをworksheet2(1月)〜worksheet13(12月)までの.range("A1:H14)までにしたい場合は
Set rngカレンダー = Worksheets(Array("1月", "2月", "3月", "4月", "5月", "6月", "7月", "8月", "9月", "10月", "11月", "12月").range("A1:H14")

で合っていますか？
・ツリー全体表示
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
105 / 3841 ﾍﾟｰｼﾞ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free