- ベストアンサー
矩形範囲の複数列を縦１列に並べ替えVBA(続)
eden3616の回答
- eden3616
- ベストアンサー率65% (267/405)
対象のデータが公開されないため、具体的なデータの状況をこちらで把握する必要があります。 そのため順を追って各列の状態を把握しておりますので 回りくどい質問のやり取りが続いておりますがご了承ください。 開示可能なデータであれば外部ストレージサービス等を用いてデータを拝見させていただければ作業が進むかと思います。 （情報の公開が不可能であれば、データの表現される可能性を全て網羅している簡略化されたモデルケースのデータでも構いません） >使用VBAは質問VBA+No2お礼の修正のものです。(No3は無関係です) 質問のVBAコードは古いものですよね？ 前回回答分の３パターンの出力が複合されたVBAにNo2の修正を適応されたものと判断致します。 ※もし質問されたVBAを利用されたのであれば、 ご提示の『Set myRng = Range("E1:K150")』はコード内では使用しておりません。 >=IF(B15="","",IF(C15="","■"&$A$1,C15)) >（G列の例・表示は■*****または****） >=IF(B15="","",IF(C15="","■",C15)) >（I列の例・表示は""または****） >=IF(A37="",IF(ISERR(FIND("■",B37,1)),"","■"&B37),A37&"-"&B37&"("&C37&")") >(E列の例・表示は表示は■*****または****) 数式の記入されているセルですが、行数が記載されていませんので 頭二つの数式はそれぞれセルG15、I15で、 最後の数式はE37行目に記載されているということでよろしいでしょうか？ >&$A$1がない列もある 無いというのはセルA1が空白""であるという事ですか。 それとも、数式として無いという事でしょうか。 何れにせよ、B列が空白以外でC列が空白ですと「■」とはなりますが。 >すなわちここではE、F、G列は並べ替えとタブ貼り付けデータを共用しているため、扱いを変える必要がある。 このE、F、G列とは 上記数式が入っている箇所ということであればF列でなくIということでしょうか。 それとも数式はI列でなく、F列に入っているのでしょうか。 >両方ともそうであるかとに理解していました。 >いままで「パターン１」も空白行は行ツメされていた No5で以下のように回答した箇所は、「任意の順番」と記述した通り、「空白を無視する処理」ではなく、「並び替えを行う処理（パターン(1)にのみ適応）」という意味になります。 ――――――――――――――――― 任意の順番は上記パターンの(1)であり、左が空白で出力するのはパターン(2)であると認識しています。 元々並び替えを行ったパターン(1)の出力にそのような処理をいれていませんが。 ――――――――――――――――― >（最左列が空白の場合）現状は書き出し後に空白が発生しています。 パターン(2)には並び替えを行わずそのままの塊で出力するものと認識しております。 現在の処理では指定範囲『Set myRng = Range("E1:K150")』での最左の列 つまりE列が空白であればその行は無視されます。 空白が発生する原因が何かをつかむ必要がありますね。 手持ちのコードでは正常に処理されており、確認が出来ません。 関連するパターン(2)の出力処理部を記述いたします。 （※パターン(2)では(1)のような列の並び替え処理はなく、データのまま出力されます） ―――――――――――――― For j = 1 To myRng.Rows.Count word = "" flag = 0 For i = 1 To myRng.Columns.Count If myRng.Cells(j, i).Value <> "" Then flag = flag + 1 End If word = word & myRng.Cells(j, i).Value If i < myRng.Columns.Count Then word = word & vbTab Next i If flag > 0 And myRng.Cells(j, 1).Value <> "" Then objTS.WriteLine word '★ Next j ―――――――――――――― 「 '★」の箇所で範囲（E1:K150）の最左列（E列）が空白であれば出力されません。 >これらのセルのうち■が含まれるセルはパターン１による並び替えに際しセルを省略したい。 パターン(2)での問題点は別として、パターン(1)の処理としての最終形としましては 指定したE1～O150列の範囲において、「文字列の先頭に「■」がある」または「対象が空白""である」場合は除外して１列でパターン（"E,M,F,G,L,N,O"）順で抜き出したいという事でよろしかったでしょうか。 If Cells(gyou, stcol).Text <> "" Then objTS.WriteLine Cells(gyou, retu).Text End If の箇所を以下のようにしてください。 If Cells(gyou, stcol).Text <> "" Then If Left(Cells(gyou, retu).Text, 1) <> "■" Then objTS.WriteLine Cells(gyou, retu).Text End If End If と、この修正をしていて気付いたのですが、 現状のコードで「If Cells(gyou, stcol).Text <> "" Then」の部分。 「st = "E3"、ed = "O150"」で指定した範囲の最左側の列（E列）が空白だと読み飛ばしていますね。 つまり、パターン(1)の場合でも一番左のE列が空白であれば「E,M,F,G,L,N,O」すべて読み飛ばされます。 今更ながら、このような処理では不都合がありませんでしょうか？ 対象のセルが空白、または文字列の先頭が■であれば読み飛ばすという処理にするのであれば If Cells(gyou, retu).Text <> "" Then If Left(Cells(gyou, retu).Text, 1) <> "■" Then objTS.WriteLine Cells(gyou, retu).Text End If End If のようにしてください。
関連するQ&A
- 複数の列を繋げてＡ列に入れたい ＶＢＡ
aaa aaa bbb aaa bbb ccc aaa (A列にaaa、B列にbbb、C列にcccが入ってます) と言うデータがあるのですが 全てＡ列に入れて aaa aaabbb aaabbbccc aaa としたいです。 ・最終列は必ずしもＣではないのです。（Dの場合もEの場合もある） ・最終行も変化します。 Sub 分かれてる列を繋げる() Dim Col As Long Dim Row As Long For Row = 1 To Range("a65536").End(xlUp).Row For Col = 1 To Cells(Row, 256).End(xlToLeft).Column Cells(Row, 1) = Cells(Row, 1) & Cells(Row, 2) & Cells(Row, 3) Next Col Next Row End Sub をやってみましたが、 aaa aaabbbbbb aaabbbcccbbbcccbbbccc aaa となってしまい、 欲しい結果とは違くなってしまいます。
- ベストアンサー
- オフィス系ソフト
- VBA最終列の取得/不規則な処理
VBAにて、最終列の取得ができません。 また、繰り返し処理を3列処理、step5、3列処理、step5…と繰り返し行う方法もご教授いただきたいです。 エクセルはo365を使用しております。 ①最終列の取得 実際は300列近くの表になります。 最終行は取得できたのですが、最終列がなぜかエラーも出ず、処理が行われません。 ②不規則な繰り返し処理 画像の水色部分のみ処理を行いたいです。 3列処理と記載したのですが、セル結合しているので、考え方が合っているのかも不明です。 塗りつぶされているセル一つ一つに処理を行いたいです。 また、行列共に可変します。 実行したいマクロは、選択したブックのSheets(1)の表の中の水色に入力されている文字列が「1」か「2」か判断するというものです。 「１」と入力されていれば → 別ブックのA1セルに１をカウント 「２」と入力されていれば → 別ブックのB1セルに１をカウント ※水色セルは参考で用意したものなので、実際は塗りつぶしされていません。 ※空白のセルもあります ①②の解消法のご教授をよろしくお願い致します。 =============================================== Option Explicit Sub kurikaeshi() Dim retu As Long, gyou As Long Dim File As Workbook Set File = Workbooks("test.xlsx") Dim ws1 As Worksheet, ws2 As Worksheet Set ws1 = File.Sheets(1) Set ws2 = ThisWorkbook.Sheets(1) Workbooks.Open FileName:=ThisWorkbook.Path & "/" & File For retu = 2 To ws1.Cells(4, ws1.Columns.Count).End(xlToLeft).Column 'ここが処理されません For gyou = 4 To ws1.Cells(ws1.Rows.Count, 2).End(xlUp).Rows If ws1.Cells(gyou, retu).Value = "1" Then ws2.Range("A1") = ws2.Range("A1") + 1 If ws1.Cells(gyou, retu).Value = "2" Then ws2.Range("B1") = ws2.Range("B1") + 1 End If Else Exit Sub End If Next gyou Next retu End Sub
- ベストアンサー
- Visual Basic
- Excel VBA 配列による複数セルへの入力
VBA初心者です．よろしくお願いいたします． 用語の読みを自動で振るシートを作成しているのですが，Do Loop部分が一行ずつの入力となっていて，時間がかかっています． これを配列等の方法を用いて高速化したいと思って，試行錯誤したのですが，うまくいきません． 何卒お教えくださいますようお願いいたします． 用語の読みを生成する手順ですが， １．シート1に用語をペーストする ２．ペーストされた用語をシート２にある用語のDB（用語と読みが入力されています．重複レコードなし）にコピー ３．コピーされたシート２をピボットにして個数が２以上あった場合，その用語と読みを返します． ４．Do Loopで最初にヒットした用語に戻るまでループ となっています． ３までの手順に修正の必要はないのですが，４の手順でかなり時間をロスしております． ここを配列等の方法で一度に書き込むことができればと思っています． Sub test() i = 8 L_Row04 = 180188 Dim S1 As Worksheet '読みを振る用語をペーストするシート Dim S2 As Worksheet '読み用の用語のDB Dim S3 As Worksheet 'ピボット Dim L_Row01 As Long 'S1にペーストされた用語の最下行 Dim L_Row02 As Long 'S1の用語をs2にペーストしたときの最下行 Dim L_Row03 As Long 'ピボットの用語の最下行 Dim Rng01 As Range 'S1にペーストされた用語の範囲 Dim Rng02 As Range 'S2にペーストされた用語の範囲 Dim Rng03 As Range 'ピボットの範囲 Dim Str01 As Variant 'ピボットで2以上あったときの用語 Dim Str02 As Variant 'ピボットで2以上あったときの読み Dim firstcell As Range Dim Foundcell01 As Range Set S1 = Worksheets(1) Set S2 = Worksheets(2) Set S3 = Worksheets(3) S1.Activate L_Row01 = S1.Cells(Rows.Count, 2).End(xlUp).Row L_Row02 = S2.Cells(Rows.Count, 3).End(xlUp).Row Set Rng01 = S1.Range(Cells(i, 2), Cells(L_Row01, 2)) Rng01.Copy Destination:=S2.Cells(L_Row02 + 1, 2 + 1) S3.PivotTables("ピボットテーブル2").RefreshTable S2.Activate L_Row02 = S2.Cells(Rows.Count, 3).End(xlUp).Row Set Rng02 = S2.Range(Cells(L_Row04, 3), Cells(L_Row02, 3)) Rng02.Delete S3.Activate L_Row03 = S3.Cells(Rows.Count, 2).End(xlUp).Row Set Rng03 = S3.Range(Cells(4, 2), Cells(L_Row03, 2)) For Each a In Rng03 If a >= 2 And a.Offset(0, -1).Value <> "(空白)" And a.Offset(1, -1).Value <> "(空白)" Then Str01 = a.Offset(0, -1) Str02 = a.Offset(1, -1) S1.Activate Set Foundcell01 = Rng01.Find(What:=Str01, searchorder:=xlByRows, LookIn:=xlValues, lookat:=xlWhole) Do Selection.Offset(0, 1).Value = Str02 Selection.Offset(0, 2).Value = "●" Loop Until ActiveCell.Address = firstcell.Address End If End If Next End Sub
- ベストアンサー
- Visual Basic
- VBA 空白表示させたい
教えて頂いたＶＢＡなのですが Sub Macro1() Dim Ws01 As Worksheet Dim Counter As Long, i As Long, j As Long Dim INP As String Set wS = Worksheets("Sheet4") wS.Cells.ClearContents If Selection(Selection.Count).Row <> 2 Then Exit Sub Counter = 0 For i = 3 To ActiveSheet.UsedRange.Rows.Count INP = "" For j = Selection(1).Column To Selection(Selection.Count).Column If Cells(i, j) = 1 Then INP = INP & Cells(2, j) & "," End If Next j If INP <> "" Then Counter = Counter + 1 wS.Cells(Counter, "A") = Left(INP, Len(INP) - 1) End If Next i End Sub ---------------------------------------------------------------------- ｇ ｈ ｉ ｊ パセリ クレソン メキャベツの葉 ごぼう １ １ １ １ １ 1行目 パセリ,クレソン,メキャベツの葉 2行目 3行目 パセリ,メキャベツの葉 と、2行目は詰めずに空白表示したいです。 どこをどうすればできますか？
- ベストアンサー
- Excel（エクセル）
- VBAで複数ファイルのページ数出力
Win10のOffice365のExcelを使用しています。 GetOpenFilenameで選択した複数のExcelファイルのファイル名＋印刷ページ数を マクロを実行したファイルに出力するというマクロを作成しました。 マクロを実行する度に既存データがあれば追加されていくようにしたいのですが、上手くいきません。 それどころか、実行時も複数ファイル選択したにも関わらず、 １ファイルのデータしか出力されない状態です。 実行後のイメージは添付ファイルの通りです。 （A1、A2はデフォルトで入力しています。） 勉強を始めたばかりなので改善点もあれば、教えて頂きたいです。 よろしくお願い致します。 ================================================= Option Explicit Sub pagecount() Dim Page As Long, cnt As Long, xlcnt As Long Dim fs As Variant, path As Variant Dim Fname As String Dim i As Integer Dim wb1 As Workbook, wb2 As Workbook Dim sh As Worksheet With CreateObject("WScript.Shell") .CurrentDirectory = ThisWorkbook.path End With fs = Application.GetOpenFilename(filefilter:="Microsoft Excelブック,*.xls*", MultiSelect:=True) If IsArray(fs) Then For Each path In fs Set wb1 = Workbooks.Open(path, , True) Set wb2 = ThisWorkbook Do Until (Fname = "") Page = 0 For Each sh In wb1.Worksheets Page = Page + sh.PageSetup.Pages.Count Next sh xlcnt = Cells(Rows.Count, 1).Row cnt = Cells(xlcnt, 1).End(xlUp).Row If wb2.ActiveSheet.Cells(cnt, 1).Value <> "" Then wb2.ActiveSheet.Cells(cnt, 1).Value = Fname wb2.ActiveSheet.Cells(cnt, 1).Offset(0, 1) = Page wb1.Close savechanges:=False Fname = Dir() cnt = cnt + 1 End If Loop Next path End If End Sub
- ベストアンサー
- Visual Basic
- ＥＸＣＥＬ ＶＢＡ データのある範囲の特定が悪い？
アンケート調査票を簡単につくために、下のようなマクロを教えていただいたのですが、もとデータ項目の参照範囲がセルのＢ５より上にあるもの（空白の場合も）も項目としてしまっているようなので、どこを手直しすればいいのか、すみませんが教えてください。 Sub test() '定数の設定 Const strInputSheet As String = "Sheet1" Const lngInputRow As Long = 5 Const lngInputCol As Long = 2 Const strOutputSheet As String = "Sheet2" Const lngOutputCol As Long = 3 Const lngOutputRow As Long = 4 Const strMessageA As String = " は " Const strMessageB As String = " に対してどの位影響があると思いますか？" '定義 Dim lngMaxRow As Long Dim lngCountA As Long Dim lngCountB As Long Dim strA As String Dim strB As String Dim lngRow As Long '項目数を把握 Sheets(strInputSheet).Select Cells(ActiveSheet.Rows.Count, lngInputCol).Select Selection.End(xlUp).Select lngMaxRow = Selection.Row 'Ｂ列のデータ最終行を取得 lngRow = lngOutputRow '出力開始行の設定 '項目Aをなめる For lngCountA = lngInputRow To lngMaxRow strA = Cells(lngCountA, lngInputCol).Value '項目Aの取得 '項目Bをなめる For lngCountB = 1 To lngMaxRow If lngCountA <> lngCountB Then '項目Aと項目Bが同じときはここは処理しない strB = Cells(lngCountB, lngInputCol).Value '項目Bを取得 Sheets(strOutputSheet).Cells(lngRow, lngOutputCol).Value = strA & strMessageA & strB & strMessageB '文字列を結合 lngRow = lngRow + 1 '改行する End If Next lngCountB Next lngCountA End Sub
- ベストアンサー
- オフィス系ソフト
- マクロ 入力する文字に色を付けたい
Sub CountUp(ByVal mCol1 As String, mCol2 As String) Dim LastRow1 As Long Dim LastRow2 As Long Dim mRow As Long With Sheets("プレーヤー") LastRow1 = .Cells(Rows.Count, mCol1).End(xlUp).Row LastRow2 = .Cells(Rows.Count, mCol2).End(xlUp).Row If LastRow1 > LastRow2 Then mRow = LastRow1 Else mRow = LastRow2 End If If LastRow1 = 1 Then LastRow1 = 2 End If .Cells(mRow + 1, mCol1).Value = .Cells(LastRow1, mCol1) + 1 End With End Sub このコードに文字の色の指定をしたいです Selection.Font.ColorIndex = 3を入れたら赤色文字で入力できるかなと思ったのですがうまくいきませんでした（エラーにはならないのですが、色が付かなかったです）
- ベストアンサー
- Excel（エクセル）
- VBAで文字列のカウントがうまくいかない・・・です
Dim cnt As Long Dim i As Long Dim lastRow As Long For i = 1 to 20 step 2 lastRow = Cells(65536, i).End(xlUP).Row cnt = WorksheetFunction.CountIf(ActiveSheet.Range(Cells(10, i),Cells(lastRow, i), "お世話になっております")cnt = cnt + cnt Next Excelのセルを1列ずつ飛ばして列に「お世話になっております」が含まれたら件数をカウントしています。 そのカウント数が何故かリセットされてしまいます。 カウント数を足していきたいのですが・・・考え方自体が違うのでしょうか？
- ベストアンサー
- Visual Basic
- Excel VBA オートフィルの範囲指定
Excel VBA で関数を入れたセルを最下行までコピー させたいのですが、範囲の指定がうまくできません。ごちゃごちゃ書きすぎて、よくわからなくなってしまいました。 実行してみたら、オートフィルのところでデバッグが出ました。 VBAはまだまだ初心者レベルです・・・ どこをどう直せばきちんと処理されるのか、どなたかお知恵をお貸しください。 （それと初めの定義は、Rangeで合ってるのでしょうか？） Sub sample() Dim MyCell1 As Range Dim MyCell2 As Range Dim MyCell3 As Range Dim MyCell4 As Range Dim MyCell5 As Range Set MyCell1 = Cells(5, Range("4:4").Find(what:="○○", searchorder:=xlByColumns).Offset(1, 1).Column) Set MyCell2 = Cells(5, MyCell1.Offset(0, 2).Column) MyCell1.Select Selection.Formula = "=$A5-" & MyCell2.Address(False, True) Set MyCell3 = Cells(5, MyCell1.Offset(0, -1).Column) Set MyCell4 = Cells(5, Cells(5, Columns.Count).End(xlToLeft).Column) Set MyCell5 = MyCell1.Offset(0, 1) MyCell5.Select Selection.Formula = "=" & MyCell3.Address(False, True) & "-" & MyCell4.Address(False, True) Range(MyCell1, Cells(5, MyCell1.Offset(0, 1).Column)).Select Selection.AutoFill Destination:=Cells(Cells(5, MyCell1.Column), Cells(Cells(Rows.Count, 1).End(xlUp).Row, MyCell5.Column)), Type:=xlFillCopy End Sub ********************* 下のような表に関数を入力して最下行までコピーさせたいです。 ｜ A ｜ B ｜ C ｜ D ｜ E ｜ F ｜ G ｜ H ｜ I ｜ J ｜ K ｜ L ｜ -------------------------------------------------------------------------- 4 | code | name | 7/1 | 7/2 | ○○ | | | code|name| 7/1 | 7/2| ○○ | 5 |10000|aaaaaa| 15 | 20 | 35 | | |10001|bbbbbb| 13 | 25 | 38 | (( )) F5に "=$A5-$H5" と数式を入れてcodeを比較し、G5に "=$E5-$I5"と入れて数量を比較する。 F列とG列の入力されている最下行まで数式をコピーする。 ※毎月日数が変わり、商品数も変わるので、A列・B列・４行目以外は全て可変。 WindowsXP Excel2003 です。 よろしくお願いいたします。
- ベストアンサー
- オフィス系ソフト
- Excel VBA; 複数のループ処理
↓のようなコードがあります。 Dim i As Long, MaxRow1 As Long, MaxRow2 As Long MaxRow1 = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row MaxRow2 = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row For i = 1 To MaxRow1 Worksheets("Sheet1").Cells(i, 1).Value = i . Next i For i = 1 To MaxRow2 Worksheets("Sheet2").Cells(i, 1).Value = i . Next i これらを最大行の多いシートに合わせて、パフォーマンスを良くしたいと思います。 同様の処理をシート1、シート2で実施しているので纏めて記述したいです。 シート1、シート2に対する処理をサブルーチンにする方法しかありませんか? どなたかお願いします。 If MaxRow1 >= MaxRow2 Then For i = 1 To MaxRow1 Else For i = 1 To MaxRow2 End If Worksheets("Sheet1").Cells(i, 1).Value = i Worksheets("Sheet2").Cells(i, 1).Value = i . Next i
- ベストアンサー
- Visual Basic
お礼
遅くなりました。 たしかにデータシートを使いながらの方が対応してもらいやすいと思っていますが、このサイトが一般公開されているため、個別データの所在等が提供できない状態で申し訳ないです。（個別に提供できる方法があるなら対応は可能なのですが） ここで再度整理させていただきます。 使用VBAは質問欄のものではなく質問欄にNo1の「当方お礼」にある修正を加えたものです。（タブ貼り付け等追加） 従来のもの (1)元データエリアA,B (2)並べ替えエリアE1,J150 (3)タブ貼り付けエリアN1:T150 にデータがあります。 (1)の内容は、1,2行目に■を含む文字列（タイトル等）、そのあと途中（例えば11行目、23行目等）にもサブタイトルのように■を含む文字列が入っています。 (1)はパターン3として、出力の末尾にそのままタブ状態で追記します。（データエリアの保存） (2)のエリアは列単位で１列に並び替えます。（パターン１） この場合、A列で■のあるサブタイトル部分は各列とも空白表示(="")をしています。 （当方提示の例示関数式は色々あるため無視してください） 並べ替えの際、エリアの最左列が空白セルの場合、その行は 削除して詰めるという処理をしていただいています。 (3)は別フォームに貼り付けるデータのためタブ形式にして矩形そのままテキストに追記貼り付けています。 （パターン２） このエリアは元データに■がある行もそのまま関数式により■入りで表示しており削除する必要がありません。 エリア(2)(3)の列の末尾は、A列にデータがなくなる行以下は150行までは(="")による空白セル表示関数入り、151行以下は関数なしの空白セルになりこれらはいずれも貼り付け並び替えの対象にしません。 以上は現状の概要です。 そこで今回の対処 エリアを整理するため、エリア(3)のうしろの列にエリア(2) を移動させました。 エリア(3)は矩形のまま列移動になるため、パターン２のタブ貼り付けは、VBAにエリアの書き換えだけでそのまま使えると思っています。(N-Tが例えばE-K) またパターン３(AB)もそのまま使えます。 問題は、パターン１の並び替えなのですが、エリア(2)と(3)から任意の列を選択します。そのため、サブタイトル部分の表示がエリア(2)のデータでは空白セルであり、エリア(3)のデータでは■入り表示になってます。 従来は並び替えエリアはサブタイトル部分を空白セルとして表示していたため単純に空白行削除で対応できたのですが 混在になってしまうためこれが不可能となりました。 そこで、サブタイトルの行はすべて■入りにしました。 そして並び替えのパータン１に限っては■入りセルは削除して行詰めにしてしまいたいのです。 なおこのため、1～2行のタイトル行も削除の対象になってしまうので、1～2行については■表示でなく●表示等別の記号に変更しようと思っています。 以上をふまえて再度ご回答いただければ幸いです。
補足
大変すみませんが、複数のBookを同じVBAで動かすためにデータを合体させている最中にあちこち関数式が正しく表示できなくなってしまい、急遽フォームを手直しするはめになってしまいました。そのため少々時間をくださるようよろしくお願いします。