- ベストアンサー
矩形範囲の複数列を縦１列に並べ替えVBA(続)
eden3616の回答
- eden3616
- ベストアンサー率65% (267/405)
ご質問の内容につきまして確認をさせて頂きます。 >データを合併させ、並べ替えとタブ貼り付けを共用させるという >魂胆だったのですが、ここで問題が生じてしまいました。 どのコードに対して作業が行われているのか明確にお願いします。 ・No3の不要部分削除したタブ区切りのデータ出力のコードのことですか？ ・No2で修正した大元のコードのことですか？ ・上記ではなく、新たに改変されたデータでしょうか？ 取り扱っているデータのパターンは以下の分類と認識しています。 (1)並び替え：列を並び替えての１行出力データ → st = "E1"～ed = "N150"で指定した範囲（行） → srt = "M,E,F,N,H,G,I,L"で指定した順番 (2)タブ貼付：短径で左列が空白の場合にその行は飛ばす → Set myRng = Range("E1:K150")で指定した範囲 (3)BC列：行数不定でタブ区切りで出力 → B、C列をタブ区切りで出力 ※上記範囲はNo2の回答で提示した範囲を元に判断致します。 >データの1～2行目と途中10行置きくらいに■を含む文字列を >仕切り線のような形で入れてタブ貼り付けエリアでは表示 タブ貼付エリアとは上記パターンの(2)に該当するものでしょうか。 >1～2行目はタイトル部分なのでいいとして、 >途中の■を含む文字列セルはタブ貼り付けの方では必要なのですが、 タイトル部分である２行目を飛ばして範囲選択されると良いのではないでしょうか。 E3:K150など。 >並べ替えの方は不要なので、並び替えエリヤでは関数で空白("")処理をしていたため、 >空白行の削除ということでつめていただいていました。 If Cells(gyou, stcol).Text <> "" Then objTS.WriteLine Cells(gyou, retu).Text End If 上記コードで空白行『""』以外『<>』の場合、セルの値『Cells(gyou, retu).Text』を出力『objTS.WriteLine』しています。 >ほか、任意の順番ということで、 >今まで最左セルが空白の場合その行は削除というルールが適用されなくなり >空白セルも詰めることなくそのまま出力されてしまいます。 任意の順番は上記パターンの(1)であり、左が空白で出力するのはパターン(2)であると認識しています。 元々並び替えを行ったパターン(1)の出力にそのような処理をいれていませんが。 (2)の処理内では以下の処理により該当の機能を持たせております。 If flag > 0 And myRng.Cells(j, 1).Value <> "" Then objTS.WriteLine word 上記コードで範囲E1:K150の対象の行で文字列が1つのセル以上見つかり、 かつ最左のセルが空白以外である場合は出力します。 >ところが共用にしたため並べ替えの方に一部■が入ってしまうことになり、 >不要なセルも表示されてしまう >そこで、並べ替えの方だけ、■を含む文字列（1～2行目を除く）のあるセルと >空白のセルは削除して詰めてしまうようにしたいのですが可能でしょうか。 空白以外にセルの値に一部「■」が含まれていれば除外するように条件を追加すれば 対象から外すことはできますが、それに伴う問題はありませんでしょうか？ また、■が具体的にどのような形で表現されているのかが提示されていませんので 適格なコードが記述できません。 パターン（対象の特徴など）、規則性（全てに適応される共通条件）、対象（セルの場所） などのような具体的な例をもってお願いします。 たとえば、 E1：K150の範囲で、E列の値に「■■■■■■■■」と入っており、F～Kが空欄である 一部■とは「■○○○○」というように項目名が記述されているなど。 もし以下のような場合、データ(4)とデータ(5)の取扱いに困りますし、 存在しないのであれば丸々読み飛ばす処理を行います。 データ(1) データ(2) データ(3) ■■■■ データ(4) データ(5) データ(6) データ(7) データ(8)
関連する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は質問VBA+No2お礼の修正のものです。(No3は無関係です) st = "E1" ed = "O150" Set myRng = Range("E1:K150") srt = "E,M,F,G,L,N,O" ※並べ替え(ハターン１） E,M,F,G,L,N,O 途中に =IF(B15="","",IF(C15="","■"&$A$1,C15)) のように入ります。（G列の例・表示は■*****または****） &$A$1がない列もある =IF(A40="","",A15)) のように入ります。（I列の例・表示は""または****） =IF(A37="",IF(ISERR(FIND("■",B37,1)),"","■"&B37),A37&"-"&B37&"("&C37&")") (E列の例・表示は表示は■*****または****) すなわちここではE、F、G列は並べ替えとタブ貼り付けデータを共用しているため、扱いを変える必要がある。 これらのセルのうち■が含まれるセルはパターン１による並び替えに際しセルを省略したい。 「■文字列」または空白セルの表示は横１行すべてに発生しします。 (ハターン３） ※B,Cの書き出しも残す 上記セルは入ったままにしておく（現状どおり） >タブ貼付エリアとは上記パターンの(2)に該当するものでしょうか。 (ハターン２） ※タブ入りの矩形貼り付け書き出しは次になります。 E1..K150 上記セルは入ったままにしておく（現状どおり） >タイトル部分である２行目を飛ばして範囲選択されると良いのではないでしょうか。 そうですね。あとで気がつきました。 >任意の順番は上記パターンの(1)であり、左が空白で出力するのはパターン(2)であると認識しています。元々並び替えを行ったパターン(1)の出力にそのような処理をいれていませんが。 両方ともそうであるかとに理解していました。 いままで「パターン１」も空白行は行ツメされていたので、その処理がされているかと思っていました。（最左列が空白の場合）現状は書き出し後に空白が発生しています。 >E1：K150の範囲で、E列の値に「■■■■■■■■」と入っており、F～Kが空欄である ここでは対象のE,M,F,G,L,N,Oを想定していますが、行単位で■が入る行はすべての列に入ります。 また空白セルの行は元データがない行。（横１行すべて空白） 基本的なパターンはB列（またはA列)に■が入っているデータの場合、その行はすべて■が入る（「またはA列」というのは別Bookの場合ですが今回の措置で統一しようとしています） A列が空白の場合はその行はすべて空白表示になります。（データの１行あけとか元データがない行）
補足
>タイトル部分である２行目を飛ばして範囲選択されると良いのではないでしょうか。 そうですね。あとで気がつきました。 といったもののタイトルも出力範囲に入れる必要があるのではずすわけにはいきませんでした。