[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『色付き空白セルを含む行削除』（ヒロセ）
お世話になっております。
表題につきましてご教示いただきたく存じます。
【１】の状態のシートを【２】の状態になるようにガッと削除、最終行のENDも削除、A列に空白があった場合削除
というコードを組んだのですが、【１】の14行目から18行目に当たる部分が削除されません。
セルにスペースが入っていないことも確認済みです。
色付きだから削除されないのか、
それとも空白に見えるしスペースも入っていないが空白ではないのか・・・
お知恵をお貸しくださいませ・・・
【１】
|[A] |[B] |[C] |[D] |[E] |[F] |[G] |[H] |[I] |[J] |[K] |[L] 〜 | |[Q]
[1] |D1228 |入力 | | | | | | | | | | |
[2] |単位： |0002 | |〇〇部 | | | | | | | | |
[3] |シナリオ： |8月 | |年度： |2024 | | | | | | | |
[4] |予算： |VB001 | |〇〇課 | | | | | | | | |
[5] |バージョン |1 | | | | | | | | | | |
[6] | | | | | | | | | | | | |
[7] |(単位：千円)| | | | | | | | | | | |
[8] | 管理No. | 目的 | 科目 |名称 |資産 | | |取得年月 |開始年月 | |
[9] | |コード |名称 |コード |名称 | |コード |名称 |年数 | | | |金額
[10]| | |合計 | | | | | | | | | |
[11]|BP00100FUJI |010 |新規 |0AA |(3年) |小型焼成炉 |170 |〇 |3 |2024/12 |2024/12 | |5,000
[12]|BP00101FUJI |010 |新規 |0AA |(3年) |電気炉 |170 |〇 |3 |2024/12 |2025/01 | |4,176
[13]|BP00200ENDO |030 |変更 |0BA |(3年) |転写機 |170 |● |3 |2024/04 |2024/06 | |916
[14]| | | | | | | | | | | | |
[15]| | | | | | | | | | | | |
[16]| | | | | | | | | | | | |
[17]| | | | | | | | | | | | |
[18]| | | | | | | | | | | | |
[19]|END | | | | | | | | | | | |
【２】
|[A] |[B] |[C] |[D] |[E]
[1] |管理No. |資産名称 |取得年月 |開始年月 |合計
[2] |BP00100FUJI |小型焼成炉 |2024/12 |2024/12 |5,000
[3] |BP00101FUJI |電気炉 |2024/12 |2025/01 |4,176
[4] |BP00200ENDO |転写機 |2024/04 |2024/06 |916
[5] | | | | |
With ws
' 1. 最終行の「END」を削除
On Error Resume Next
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If .Cells(lastRow, 1).Value = "END" Then
.Rows(lastRow).Delete
End If
Err.Clear
On Error GoTo 0
' 2. A列が空白であればその行を削除
On Error Resume Next
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row ' 再度最終行を取得
For i = lastRow To 1 Step -1
If IsEmpty(.Cells(i, 1).Value) Then
.Rows(i).Delete
End If
Next i
Err.Clear
On Error GoTo 0
' 3. 指定された行を削除
On Error Resume Next
.Rows("8:9").Delete Shift:=xlUp
.Rows("1:6").Delete Shift:=xlUp
Err.Clear
On Error GoTo 0
' 4. 指定された列を削除
On Error Resume Next
.Columns("O:Q").EntireColumn.Hidden = False
.Columns("L:P").Delete Shift:=xlToLeft
.Columns("G:I").Delete Shift:=xlToLeft
.Columns("B:E").Delete Shift:=xlToLeft
Err.Clear
On Error GoTo 0
End With
＜ 使用 Excel：Microsoft365、使用 OS：Windows11 ＞
A列の14行目から18行目がEmptyのとき → lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row で lastRowは13になるので削除されない
A列の14行目から18行目がEmptyじゃないとき → If IsEmpty(.Cells(i, 1).Value) Then が成立しないので削除されない
Debug中は、On Error とかつかない方がいいですよ （´・ω・`） 2024/09/02(月) 12:17:17
ご回答ありがとうございます。
なるほど・・・矛盾が起きてしまっているのですね。
ENDが入っていればENDが最終行になるので消えるのでは、と思っていたのですが、
ENDを先に消したことで最終行が繰り上がってしまった。ということでしょうか
やはり難しいです・・・
これはどちらかを変更すれば消えるようになるのでしょうか？
On Errorはつけずにマクロ走らせてみます。
（ヒロセ） 2024/09/02(月) 12:27:54
ありがとうございました！
（ヒロセ） 2024/09/02(月) 12:36:57
ほんとうですか？ 空白行を消す処理を先にしたらENDの行が最終行になるので、何もせずに終わると思いますが
If IsEmpty(.Cells(i, 1).Value) Then を If .Cells(i, 1).Value)=""Then にするのがいいのだとおもいましたが....
できているということなら、これ以上いうことはありません。 （´・ω・`） 2024/09/02(月) 13:24:48
何度か走らせましたが問題なく消えていました。
もしかしたら
If Trim(.Cells(i, 1).value) = "" Then
に修正したからかもしれません。
（ChatGPTに相談したところ、これに修正してはどうかとの意見がありまして）
すみません、ありがとうございます。
IsEmptyを削除するだけでよかったんですね・・
まだ勉強中のため、いろんな書き方を学習していきたいと思います。
（ヒロセ） 2024/09/02(月) 13:49:55
>If Trim(.Cells(i, 1).value) = "" Then >に修正したからかもしれません。 ですよね。
削除する順番ではなくて、Ifの条件の変更が効いてるはずです （´・ω・`） 2024/09/02(月) 16:00:35
Trimにしたことで、空白行が消えるようになったのですね。
Trimについて勉強せねば、です。
ITさん
シート自体はOneDriveへ保存されていますし、提出用のブックなので問題ありません。
ローカルの分をガッと削除してます。
（ヒロセ） 2024/09/02(月) 16:25:40
（?） 2024/09/02(月) 21:02:24
Sub 研究用01()
Dim dstWS As Worksheet
With ActiveSheet
Set dstWS = Worksheets.Add(after:=Worksheets(.Name))
Intersect(.Rows("11:" & .Rows.Count), .Range("A:A,F:F,J:K,Q:Q")).Copy dstWS.Range("A2")
dstWS.Range("A1:E1").Value = Array("管理No.", "資産名称", "取得年月", "開始年月", "合計")
'〜〜〜オートフィルタでA列が（空白）or "END" のものを抽出する
'〜〜〜抽出されている行全体を削除する〜〜〜〜〜
'〜〜〜オートフィルタを解除する〜〜〜〜
End With
End Sub
※ 〜〜〜〇〇〇〜〜〜の部分は、【マクロの記録】でたたき台となるコードが得られると思います。
（もこな２） 2024/09/03(火) 07:40:07
１行目の項目名ですか？どれでしょうか・・
すべてマクロで補えるようになっている（と思っている）のですが・・
もこな２さん
新しいシートに抽出ですか
削除して保存すればいい、としか考えていなかったため（先月までそのやり方だったため）なるほど、と
こちらのやり方も試してみます。
ありがとうございます。
（ヒロセ） 2024/09/03(火) 08:33:06
【２】の１行目は、【１】の８行目そのままです。
手作業はミスにつながるおそれがあり怖いですからね・・・
（ヒロセ） 2024/09/03(火) 09:10:28
こういうことでしょうか？
Sub test()
Dim a, x
With Sheets("sheet1").UsedRange
If .Parent.Evaluate("max(if(" & .Address & "<>"""",column(" & .Address & ")))") < 17 Then Exit Sub
x = Filter(.Parent.Evaluate("transpose(if(left(" & .Columns(1).Address & ",2)=""BP"",row(" & _
.Address & ")))"), False, 0)
If UBound(x) = -1 Then Exit Sub
a = Application.Index(.Value, Application.Transpose(x), [{1,6,10,11,17}])
.ClearContents
With .Rows(1).Resize(, UBound(a, 2))
.Value = [{"管理No.","資産名称","取得年月","開始年月","合計"}]
.Rows(2).Resize(UBound(a, 1)).Value = a
.EntireColumn.AutoFit
End With
End With
End Sub
配列で処理しているので、他シートに抽出することもできます。 （jindon） 2024/09/03(火) 09:53:34
このコード、走らせてみましたが
If .Parent.Evaluate("max(if(" & .Address & "<>"""",column(" & .Address & ")))") < 17 Then Exit Sub
このExit Subからぐるぐる回っており・・・
With Sheets("sheet1").UsedRange
ここのシートを指定すればいいのか？状態です。
とても勉強になります。ありがとうございます。
（ヒロセ） 2024/09/03(火) 10:16:33
17 は Q列なので、Q列にデータがなければ Exit します。(誤操作防止のため) コードは、オープニングポストのデータ配置を基に書かれています。
その行をいったん削除して実行してみてください。 （jindon） 2024/09/03(火) 10:24:27
なるほど、Exit Subは End Subと違い、一致しなければ終了なのですね。
削除して走らせると次の行で
x = Filter(.Parent.Evaluate("transpose(if(left(" & .Columns(1).Address & ",2)=""BP"",row(" & _
.Address & ")))"), False, 0)
「型が一致しません」
とのこと。
マクロを走らせるエクセルファイルが違うんだろうか・・？
（ヒロセ） 2024/09/03(火) 10:30:20
上記にアップしましたので、確認してください。 PassWord: y0pqgc1z （jindon） 2024/09/03(火) 10:42:25
ありがとうございます。
会社のPCでは拝見出来ないようなので、昼休みにスマホから見てみます。
（ヒロセ） 2024/09/03(火) 10:53:31
アップしたのはExcel file(.xlsm)です。 データ配置の確認ならできますが、スマホでマクロは無理では？ （jindon） 2024/09/03(火) 10:57:49
明日のお返事になってしまうかもしれません、申し訳ないです。
（ヒロセ） 2024/09/03(火) 11:03:07
私も、元データを残した方がいいと思ったに過ぎないので、同じシート内での 処理にこだわるというなら、別の列にでも貼り付ければよいのではないでしょうか？
Sub 同じシート内()
With ActiveSheet
.AutoFilterMode = False
.Range("A10:Q" & .Cells(.Rows.Count, "A").End(xlUp).Row).AutoFilter
.AutoFilter.Range.AutoFilter Field:=1, Criteria1:="<>END", Operator:=xlAnd, Criteria2:="<>"
Intersect(.AutoFilter.Range, .Range("A:A,F:F,J:K,Q:Q")).Copy .Range("S1")
.Range("S1").Resize(, 5).Value = Array("管理No.", "資産名称", "取得年月", "開始年月", "合計")
On Error Resume Next
.ShowAllData
On Error GoTo 0
Stop
.Range("A:R").Delete
End With
End Sub
※コピーしてから抽出・削除するプランを案内してしまいましたが、 必要な部分のみ抽出してからコピーしたほうが効率がよいと判断したので アプローチを変更しました。
（もこな２） 2024/09/04(水) 07:34:39
もこな２さん
ありがとうございます。
元データと提出場所が別になるので、特に気にしてはいなかったのですが
コピー前に抽出すると削除の手間が省けますね、省エネです。
？さん
削除する前には特になにもしていません。
（質問の意図がわからなく、申し訳ないです）
（ヒロセ） 2024/09/04(水) 11:04:40
ヒロセさん
ファイルは圧縮していませんし、ダウンロードもできています。 アップした日から3日でリンクは無効になります。 もし既に問題が解決しているのなら、無視されても結構です。 （jindon） 2024/09/04(水) 11:46:27
確認できました、ありがとうございます。
元データに直接マクロを差し込む形式だったのですね。
（管理シートのあるエクセルで試しておりました。）
試してみたいと思います。
わざわざありがとうございました。
（ヒロセ） 2024/09/05(木) 09:02:22
データ配置はそれで合っていましたか？
他シート(管理シート)への抽出。
Sub test()
Dim a, x, wsName$
wsName = "管理シート"
If Not Evaluate("isref('" & wsName & "'!a1)") Then Sheets.Add(, Sheets("sheet1")).Name = wsName
With Sheets("sheet1").UsedRange
If .Parent.Evaluate("max(if(" & .Address & "<>"""",column(" & .Address & ")))") < 17 Then Exit Sub
x = Filter(.Parent.Evaluate("transpose(if(left(" & .Columns(1).Address & ",2)=""BP"",row(" & _
.Address & ")))"), False, 0)
If UBound(x) = -1 Then Exit Sub
a = Application.Index(.Value, Application.Transpose(x), [{1,6,10,11,17}])
End With
With Sheets(wsName).Rows(1).Resize(, UBound(a, 2))
.CurrentRegion.ClearContents
.Value = [{"管理No.","資産名称","取得年月","開始年月","合計"}]
If UBound(x) > -1 Then .Rows(2).Resize(UBound(a, 1)).Value = a
.EntireColumn.AutoFit
End With
End Sub
（jindon） 2024/09/05(木) 10:18:19
Sub 別案()
With ActiveSheet
.AutoFilterMode = False
.Range("A10:Q" & .Cells(.Rows.Count, "A").End(xlUp).Row).AutoFilter
.AutoFilter.Range.AutoFilter Field:=1, Criteria1:="=END", Operator:=xlOr, Criteria2:=""
.AutoFilter.Range.Offset(1).EntireRow.Delete
.AutoFilterMode = False
.Rows("1:9").Delete
.Range("B:E,G:I,L:P").Delete
.Range("A1").Resize(, 5).Value = Array("管理No.", "資産名称", "取得年月", "開始年月", "合計")
End With
End Sub
■２
もちろん、当初のようにループ処理でも可能ではありますが・・・・
Sub 最初のコードを修正()
Dim i As Long
With ActiveSheet
For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 11 Step -1
If .Cells(i, "A").Value = "" Or .Cells(i, "A").Value = "END" Then
.Rows(i).Delete
End If
Next
Stop 'ブレークポイントの代わり
.Rows("1:9").Delete
.Range("B:E,G:I,L:P").Delete
.Range("A1").Resize(, 5).Value = Array("管理No.", "資産名称", "取得年月", "開始年月", "合計")
End With
End Sub
■３
＞ChatGPTに相談したところ〜
あくまで私見ですが、AIはもっとも"らしい"回答を返しているだけなので、何をやっているかはきちんと理解しておくべきでしょう。
前トピックにもつながりますが、別の人が作ったものだろうがAIが生成したものだろうが、コードの改造をしようと思うなら、まず現状のコードを理解することから手を付けるべきだと思います。
（もこな２） 2024/09/05(木) 12:20:05
もこな２さん
同フォルダ内のすべてのxlsxシートに対して同じ処理を行う、ということがしたかったのですが
消す以外をループ処理、他はオートフィルター抽出からの処理、とかでも出来るんでしょうか？
きちんと調べられていないため、chatGPTにお世話になったのですが、確かにその通りです。
ようやく楽しくなってきたため、もう少しゆっくりコードの解読、理解を深めていこうと思います。
（ヒロセ） 2024/09/05(木) 13:15:16
＞ 同フォルダ内のすべてのxlsxシートに対して同じ処理を行う、ということがしたかったのですが ＞ 消す以外をループ処理、他はオートフィルター抽出からの処理、とかでも出来るんでしょうか？
できます。
というか、[[20240822141940]]の↓の部分がそういう処理ですよ。
bname = Dir(ThisWorkbook.Path & "\設備*.xlsx")
Do While bname <> ""
Set wb1 = Workbooks.Open(ThisWorkbook.Path & "\" & bname)
〜〜〜 処理 〜〜〜
wb1.Close
bname = Dir()
Loop
（もこな２） 2024/09/05(木) 13:21:32
データのあるシート名qをSheet1で想定します。 Sheet1 を実際のシート名に変更してください。
それと、コードは難しいことはしていませんので、理解してしまえば簡単に修正できます。 （jindon） 2024/09/05(木) 13:27:20
なるほど、このコードでそういう処理が・・・
ワークブック１を開いて処理、ワークブック１を閉じて次のループへ
ということですね。
なんとなくわかってきました。
これならすべてループにしなくてもよさそうです。
jindonさん
Sheet1 の部分を変えるだけで出来るのですね。
ちなみに上で説明しているように、同じようなシートが４つある場合だと
別シートの作成や、処理に工夫することですべてのシートが抽出出来るのでしょうか？
（まだ学習中なので、別シートの作成とは？なのですが・・）
（ヒロセ） 2024/09/05(木) 13:59:38
状況が的確に理解できていません。
- 同一フォルダ内にある複数のシートがある複数のブックが存在する。
1) 各シートの必要範囲を夫々どこへ出力するのですか? 2) 各ブックにあるシート名は共通ですか? （jindon） 2024/09/05(木) 14:59:03
同一フォルダ内に複数のブックがあり、それぞれシート数は違うのですが、構成は同じなんです。
１）必要範囲だけであれば、新規ブックでもなんでも出力出来れば問題ありません。
２）共通ではありません。
ブック１にはD6110、D6120、D6125があり、ブック２にはD6560があります。
ただ取り出したい箇所は同じなため、抽出→出力をすべてのシートで行いたい。という感じでしょうか
（ヒロセ） 2024/09/05(木) 15:09:11
あともう一つ... 各ブック名に特定の共通部分があれば、教えてください。 無ければフォルダ内の全てのブックが対象となりますが? （jindon） 2024/09/05(木) 16:37:16
Sub 研究用()
'コンパイルエラーにならないことしかチェックしてないので悪しからず
Const フォルダパス As String = "c:\hogehoge"
Dim ブック名 As String
Dim シート名 As Variant
Dim MySH As Worksheet
Dim i As Long
ブック名 = Dir(フォルダパス & "\*.xls?")
'▼条件にあう【ブック】を探して処理するループ
Do Until ブック名 = ""
Stop 'ローカルウィンドウで【ブック名】を確認！
With Workbooks.Open(フォルダパス & "\" & ブック名)
'▼条件にあう【シート】を探して処理するループ
For Each シート名 In Array("D6110", "D6120", "D6125", "D6560")
Stop 'ローカルウィンドウで【シート名】を確認
Set MySH = Nothing
On Error Resume Next
Set MySH = .Worksheets(シート名)
On Error GoTo 0
If Not MySH Is Nothing Then
Stop 'ローカルウィンドウで【MySH】の名前を確認
'▼A列最終行〜11行目までを順番に見ていくループ
For i = MySH.Cells(MySH.Rows.Count, 1).End(xlUp).Row To 11 Step -1
Stop 'ローカルウィンドウで【i】を確認
If MySH.Cells(i, "A").Value = "" Or MySH.Cells(i, "A").Value = "END" Then
Application.Goto MySH.Cells(i, "A")
Stop 'シートのA列i行目の値を確認
MySH.Rows(i).Delete
End If
Next i
MySH.Rows("1:9").Delete
MySH.Range("B:E,G:I,L:P").Delete
MySH.Range("A1").Resize(, 5).Value = Array("管理No.", "資産名称", "取得年月", "開始年月", "合計")
End If
Next シート名
.Close True
End With
ブック名 = Dir()
Loop
End Sub
※説明用の提示であり完成品プレゼントの意図はありません。 既に類似のコメントをしていますが、ステップ実行等により何をやっているのか調べて、 わからない命令があれば、まずはネット検索してみるてはどうでしょうか？
それでも理解できなければ、××になるとおもって〜〜〜の記述をしたけど、☆☆のような結果に
なってしまうなど、具体例をあげて質問されたほうがよいと思います。
（もこな２） 2024/09/05(木) 17:31:53
共通といえば、それぞれ「設備〜」から始まる、というところでして
ですのでこのマクロ入りエクセルのあるフォルダ中で、すべての「.xlsx」を開く。という指定にしています。
ちょっと動きがカタカタするな、というところもありますが、削除→保存がすべてのシートに行われているのでいいか。と思っていました。
jindonさんやもこな２さんのアドバイス、抽出→別ブックに保存をすべてのシートに行うというのもチャレンジしたいなと思っていますので、挑戦してみてわからない部分が出てきた際はご教示いただきたく・・・
もこな２さん
おそらくなので間違っていたらすみません。
'▼A列最終行〜11行目までを順番に見ていくループ
For i = MySH.Cells(MySH.Rows.Count, 1).End(xlUp).Row To 11 Step -1
11行以上あったりなかったりする場合、最大値に合わせても問題ないのでしょうか？
と書いてしまったのですが、
ステップ実行してネット検索、それでもわからなければご質問に伺いたいと思います。
（ヒロセ） 2024/09/06(金) 09:18:13
ヒロセさん
一つの問題に対しての解決手段は複数あります。 もっと状況をお聞きしたいのですが、一応私なりの想像も踏まえて二つのコードを提示します。 どちらも新規ブックを立ち上げ、
- ブックと同数のシートを挿入してシート名をブック名にする。 - 五列おきに各シートからの抽出データを表示する。 - 一行目にシート名 - 二行目に列項目 - 三行目以降にデータ
1) ファイル内のブックを開かない。(早い)
Sub testClosed()
Dim myDir$, fn$, s1$, s2$, wsNames, e, wb As Workbook, x, n&, t&
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then myDir = .SelectedItems(1) & "\"
End With
If myDir = "" Then Exit Sub
fn = Dir(myDir & "*.xls*")
If fn = "" Then Exit Sub
Application.ScreenUpdating = False
Set wb = Workbooks.Add(xlWBATWorksheet)
s1 = "Select F1, F6, F10, F11, F17 From `#$A11:Q` Where Trim(F6) <>'';"
s2 = "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=#;Extended Properties='Excel 12.0;HDR=No';"
Do While fn <> ""
wsNames = GetSheetName(myDir, fn)
If IsArray(wsNames) Then
n = n + 1
If n > wb.Sheets.Count Then wb.Sheets.Add , wb.Sheets(wb.Sheets.Count)
wb.Sheets(n).Name = fn: t = 1
For Each e In wsNames
On Error Resume Next
With CreateObject("ADODB.Recordset")
.Open Replace(s1, "#", e), Replace(s2, "#", myDir & fn), 3, 3, 1
If Err.Number = 0 Then
wb.Sheets(n).Cells(1, t) = e
wb.Sheets(n).Cells(2, t).Resize(, 5) = [{"管理No.","資産名称","取得年月","開始年月","合計"}]
wb.Sheets(n).Cells(3, t).CopyFromRecordset .DataSource: t = t + 6
End If
End With
Next
wb.Sheets(n).Columns.AutoFit
End If
fn = Dir
Loop
Application.ScreenUpdating = True
End Sub
Function GetSheetName(myDir, fn)
Dim tbl As Object, i&, n&, x, s, temp
With CreateObject("DAO.DBEngine.120").OpenDatabase(myDir & fn, False, False, "excel 5.0;hdr=no;")
ReDim x(1 To .tabledefs.Count)
For i = 0 To .tabledefs.Count - 1
s = Replace(.tabledefs(i).Name, "$", "")
On Error Resume Next
temp = ExecuteExcel4Macro("'" & myDir & "[" & fn & "]" & s & "'!r1c2")
If Err = 0 Then n = n + 1: x(n) = s
On Error GoTo 0
Next
End With
If n Then ReDim Preserve x(1 To n)
GetSheetName = x
End Function
2) 各ブックを開く(相対的に遅い)
Sub testOpen()
Dim myDir$, fn$, temp, a, e, x, wb As Workbook, n&, t&, ws As Worksheet
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then myDir = .SelectedItems(1) & "\"
End With
If myDir = "" Then Exit Sub
Application.ScreenUpdating = False
Set wb = Workbooks.Add(xlWBATWorksheet)
fn = Dir(myDir & "*.xls*")
Do While fn <> ""
With Workbooks.Open(myDir & fn)
n = n + 1
If n > wb.Sheets.Count Then wb.Sheets.Add , wb.Sheets(wb.Sheets.Count)
wb.Sheets(n).Name = fn: t = 1
For Each ws In .Worksheets
With Intersect(ws.UsedRange, ws.Rows("11:" & Rows.Count))
temp = 0
On Error Resume Next
temp = ws.Evaluate("max(if(" & .Address & "<>"""",column(" & .Address & ")))")
On Error GoTo 0
If temp >= 17 Then
x = Filter(ws.Evaluate("transpose(if(trim(" & .Columns(6).Address & ")<>"""",row(1:" & _
.Rows.Count & ")))"), False, 0)
If UBound(x) = -1 Then Exit Sub
a = Application.Index(.Value, Application.Transpose(x), [{1,6,10,11,17}])
With wb.Sheets(n).Cells(1, t).Resize(, UBound(a, 2))
.Cells(1) = ws.Name
.Rows(2).Value = [{"管理No.","資産名称","取得年月","開始年月","合計"}]
.Rows(3).Resize(UBound(a, 1)).Value = a
.EntireColumn.AutoFit
End With
t = t + 6
End If
End With
Next
.Close False
End With
fn = Dir
Loop
Application.ScreenUpdating = True
End Sub
（jindon） 2024/09/06(金) 11:38:25
それでもわからなければ、↓を実行してみれば理解が進むと思います。
Sub 研究用02()
Dim 行 As Long
Dim MySH As Worksheet
With Workbooks.Add
Worksheets.Add after:=Worksheets(.Worksheets.Count)
.Worksheets(1).Range("A8:A20").Value = "あ"
.Worksheets(2).Range("A3:A10").Value = "い"
For Each MySH In .Worksheets(Array(1, 2))
For 行 = MySH.Cells(MySH.Rows.Count, 1).End(xlUp).Row To 11 Step -1
Debug.Print MySH.Name & "シートのA列【" & 行 & "行目】の値は「" & MySH.Cells(行, "A").Value & "」です"
Stop ' 2番目のシートは最終行が10行目なので、そもそも「For〜Next」が実行されず、ここで止まらない
Next 行
Next MySH
End With
End Sub
（もこな２） 2024/09/06(金) 12:40:08
マクロのご提示ありがとうございます。
一度どちらも走らせてみて、どのような動きをするのか見てみます。
ブックを開く必要はないと思いますが、開いた方が効率が良い。となれば多少遅くとも2案の（ブックを開く）の使用も視野に入れるつもりです。
ほかの方もおっしゃられている通り、初歩的な質問をいくつかしておりますので、
検証し、ネットでも調べ、わからなければ質問に伺いたいと思います。
もこな２さん
ありがとうございます。
初歩の初歩でつまづいておりましたが、こちらのアドバイスで少しは理解が進みました。
いただいたコードをステップ実行しながら理解を深めます。
みなさま本当にありがとうございました。
（ヒロセ） 2024/09/06(金) 15:56:58
ヒロセさん、 私のコードをStep Debugしても、理解するのは無理だと思います。 こちらのダミーファイルでの動作確認はしています。 難しい事はしていないので、まずそちらでコードが機能するか確認したらご連絡ください。
どちらのコードでもメンテに必要な説明はします。 （jindon） 2024/09/06(金) 16:41:55
（閲覧者） 2024/09/06(金) 19:13:01
（★） 2024/09/06(金) 21:09:58
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.