Excel総合相談所 42

昇順に歯抜けなく並んでいるかできないのでしょうか。

わからないので、私は単純に横の列に0から40まで並べておいてvlookupで判断してました。

やはりそうするしかないのかなぁ

>>927さま

無事、順位算出できました。ありがとうございました。

フォームにセルを移動させるコードのボタンをつけて

showmodalをFalseにして、表示させたまま、そのボタンを押したときに
アプリケーションもアクティブにするにはどうしたらいいの

activateではセル選択自体は移動しても、フォームはアクティブになったままなので
EXCEL自体をアクティブにしたいのですがそんな方法ありますか

ごめｎできた→AppActivate "Microsoft Excel"

>>939
>>3
> 指摘されてから書き直しても、その質問にはまともな回答が付かないと思ってください。

ここはこういうスレなんだから、あきらめて他で質問しな。

>>882
>>883

遅れましたが、どうもありがとうございました。
非常に参考になりました。

>>936
色々調べてなんとか出来ました。

Private Sub Workbook_Open()
　　Dim i As Integer

　　Set Sheet1.ImageCombo1.ImageList = Sheet1.ImageList1

　　For i = 1 To Sheet1.ImageList1.ListImages.Count
　　　　Sheet1.ImageCombo1.ComboItems.Add , , _
　　　　　　Sheet1.ImageCombo1.ListImages(i).Key, i
　　Next i

　　Set Sheet1.ImageCombo1.SelectedItem = Sheet1.ImageCombo1.ComboItems(1)

End Sub

これでイメージコントロールに画像を表示して選択までは出来るようになったのですが、
エクセルの挙動があやしくなり、ファイルを閉じようとするとエラーが発生して
エクセルが落ちるようになってしましました。

Excel2003（SP2）/WindowsXP（SP2）
ImageCombo（SP6）/ImageList（SP6）
という組み合わせなのですが、何が原因か教えて頂けないでしょうか？

PC（XP）（ワード、エクセルは2003）を新しく買ったんだけど、前のPC（me)で作ったワード、エクセル（2000）が読めないんです。
どうしてでしょうか？
どうやったら読めるか教えて下さい。
ＣＤ−Ｒに入れてるものが呼び出せません。
「アクセス権がないから問い合わせて」って出るんです。

ググってもスレ内を検索しても解らなかったので質問させてください。
来週プレゼンがあるのです。
プレゼンは会議室にあるプレゼン用のパソコンを使わなくてはなりません。
それでパワーポイントを使うわけですがバージョンが古く、
僕が作ったエクセル2000のマクロ(3D)入りデータが使えません。
技術の人に「office2000をプレゼン用のパソコンにいれてもいいか？」と
聞いたら断られました。
自分のノートを持ち込むのも禁止のようです。
この場合、その3Dの画像だけJPEGにすればいいと思うのですがやり方がわかりません。
どなたかご教授お願いします。

【1 OSの種類 　 　 　 　 .】 WindowsXP
【2 Excelのバージョン 　 】 Excel2003
【3 VBAが使えるか　 　 .】 いいえ
【4 VBAでの回答の可否】 可
【5 検索キーワード 　 　 】 『範囲』『最小』等

A列には６桁の数値（商品番号。文字列として扱っている）、B列にはそれぞれの商品のカラーバリエーション数が入っています。
そして、C列にカラーバリエーション数だけ商品番号を繰り返したいのですが、どのような方法がありますでしょうか？


A列　　　B列　　C列　　　D列
000001　　3　　000001　　赤
000021　　1　　000001　　青
000801　　2　　000001　　黄
　　　　　　　　　000021　　白
　　　　　　　　　000801　　赤
　　　　　　　　　000801　　緑

このような感じです。ヨロシクオネガイシマス。

>>946-947
今日はスレ違いor板違い祭りか？

PriSc→編集

>>946
さようなら


>>947
さようなら


>>948
ほれ
Sub Sample()
　Dim strCode As String
　Dim i As Long, j As Long, k As Long

　j = 1
　For i = 1 To Cells(65536, 1).End(xlUp).Row
　　k = Cells(i, 2).Value
　　Cells(j, 3).Resize(k, 1).Value = Cells(i, 1).Text
　　j = j + k
　Next i
End Sub

事前にC列の表示形式を文字列にしておくこと
処理が遅いようならScreenUpdatingでも使ってくれ
j = 1､For i = 1の｢1｣は､データ先頭が1行目ってことを意味してるので
1行目からじゃないなら両方データの先頭行番号に書き換えろ

【1 OSの種類 　 　 　 　 .】 WindowsXP
【2 Excelのバージョン 　 】 Excel2003
【3 VBAが使えるか　 　 .】 はい
【4 VBAでの回答の可否】 可
【5 検索キーワード 　 　 】 『集計』『総当り』『三角表』等

35000行、85列（問85）の回答データがあります。
問1と問2を同時に回答している、問1と問3を同時に回答している・・・・・・問1と問84を同時に回答している、問1と問85を同時に回答している
問2と問3を同時に回答している、問2と問4を同時に回答している・・・・・・問2と問85を同時に回答している
　　　　　　　　　　　　・
　　　　　　　　　　　　・
　　　　　　　　　　　　・
問83と問84を同時に回答している、問83と問85を同時に回答している
問84と問85を同時に回答している

と言うように、85＊85のマトリックス表を作り、相関の件数をカウントしたいのですが、35000＊(85＊85)/2の処理（三角表なので）にものすごく時間がかかってます。
SPSSを使うと速いらしいのですが、私には使えません。

なんとかエクセルのVBAで高速化を図ることは出来ないでしょうか。

よろしくお願いいたします。

>>952

>>2
> ･8 うまくいかなかったにしても自分でやってみたこと(組んだ数式やコード)は書きましょう。
> 　　例えエラーになる式やコードでも、何をやりたいのかを的確に把握する手がかりになります。
> 　　その上で、どううまくいかないのかを具体的に書きましょう。
> 　　エラーが出るなら、何処でどういうエラーが出るのか、
> 　　想定外の結果が出るなら、条件と想定上の結果、実際の結果などを詳しく書いてください。

何レス使ってもいいから､まずはルールに従ってその｢ものすごく時間がかかってしまう｣コードを貼ること

>>952
三角表の出力方法をどうしたいかもわからんですね。
現状ではApplication.ScreenUpdating = Falseとすれば少しは早くなるんじゃないとしか

すみません、大変失礼いたしました。

Private Sub Count_Rtn(Sheet_Name As String)
Dim i As Long
Dim ii As Long
'サンプル数のカウント
Erase Cnt_01
lRow = 1
Sheets("抽出データ").Select
While Cells(lRow, 1) <> ""
For i = 1 To 85
For ii = 1 To 85
If Cells(lRow, i) <> "" And Cells(lRow, ii) <> "" Then
Cnt_01(i, ii) = Cnt_01(i, ii) + 1
End If
Next ii
Next i
lRow = lRow + 1
Wend

'最終行の設定
lRow = lRow - 1

'結果の出力
For i = 1 To 85
For ii = 1 To 85
Sheets(Sheet_Name).Cells((i, ii) = Cnt_01(i, ii)
Next ii
Next i
End Sub

よろしくお願いいたします。

【1 OSの種類 　 　 　 　 .】 Windows2000
【2 Excelのバージョン 　 】 Excel2003
【3 VBAが使えるか　 　 .】 いいえ
【4 VBAでの回答の可否】 可
【5 検索キーワード 　 　 】適当なワードが分かりません

�@元のデータsheet1
　Ａ　Ｂ　Ｃ　Ｄ　Ｅ　Ｆ
1あ　0　い　う　0　お
20　い　0　　0　ろは
3に　0　ほ　0　へ　0

�@のように、データの入ったセルと、データ”0”の入ったセルが混在してますが、

�Asheet2に、この様に移し変えたい
　Ａ　Ｂ　Ｃ　Ｄ　Ｅ　Ｆ
1あ　い　う　お
2い　ろ　は
3に　ほ　へ

�Aの様に、”0”を省き、左詰めしたいのですが、どうすればいいでしょう。

＞14のようにＶＢＡなら出来るのでしょうか？

>>952
こんなんでどうですか？
結果の出力はカットで

For i = 1 To 85
For ii = i+1 To 85
If Cells(lRow, i) <> "" And Cells(lRow, ii) <> "" Then
Sheets(Sheet_Name).Cells((i, ii) = Sheets(Sheet_Name).Cells((i, ii) + 1
End If
Next ii
Next i

>>952
そのまま配列で処理すれば少しは早くなるんじゃね？

Dim Val_01(), Cnt_01()
Dim i As Long, ii As Long, iii As Long
Dim QUESTION_COUNT

QUESTION_COUNT = 85
ReDim Cnt_01(QUESTION_COUNT, QUESTION_COUNT)
Val_01 = Sheets("抽出データ").Range("A1").CurrentRegion.Value

For i = 1 To UBound(Val_01)
For ii = 1 To QUESTION_COUNT - 1
For iii = ii + 1 To QUESTION_COUNT
If Val_01(i, ii) <> "" And Val_01(i, iii) <> "" Then Cnt_01(ii, iii) = Cnt_01(ii, iii) + 1
Next iii
Next ii
Next i

For i = 1 To QUESTION_COUNT
Cnt_01(0, i) = i: Cnt_01(i, 0) = i
Next

Sheets("出力先シート").Cells(1, 1).Resize(UBound(Cnt_01) + 1, UBound(Cnt_01, 2) + 1).Value = Cnt_01

>>957
レスありがとうございます。
インクリメントさせる部分は、セルへの処理よりメモリ上でやってしまった方が速いかと思ってました。
セルに直接足してしまう方が速くなるものなのでしょうか。

ちょっと試してみますね。ありがとうございました。

試したらセルに直接は激遅でした。。。>>958のようにメモリーで処理するほうがよさそうですね

>>814
>>817
有り難うございます。

シート1の数字を削除するのではなく、シート2にある数字を削除するようにできますか？
また、削除の方法は内容のデリートでお願いできませんか？

シート1のある数字をシート2で検索して削除する。といった形です。
よろしくお願いします。

>>956
VBAでもできるが､そのデータを正規表現が使えるテキストエディタにコピペして
s/0(\t|$)//g
で置換して､Excel側の元データを消したところに置換したデータを戻せば良い

>>961 やっぱり逆でしたか。読解力無くてすみませ…orz

Sub 削除()
Application.ScreenUpdating = False

Range("A1").Select
Do
mycount = Application.WorksheetFunction.CountIf(Sheets("シート１").Range("A:A"), ActiveCell.Value)
If mycount = 0 Then
ActiveCell.Offset(1, 0).Select
ElseIf mycount > 0 Then
Selection.ClearContents
ActiveCell.Offset(1, 0).Select
End If
Loop Until ActiveCell.Value = ""

'追記場所

Application.ScreenUpdating = True
End Sub

改行エラーでコピペ仕切れませんでした。
Ｇ列とＭ列でも繰り返すように　'追記場所　に書いて下さい。

なあ､質問者はともかく､回答者はちゃんとコードをインデント表示できるように貼ろうぜ。
IDEに因ってはそのままコピペすると全角スペースでエラーになるが､ExcelのVBEは
全角スペース張り付けると勝手に半角スペース2個に置き換えてくれるんだからさ。

Sub 削除()
　　Application.ScreenUpdating = False

　　Range("A1").Select
　　Do
　　　　mycount = Application.WorksheetFunction.CountIf(Sheets("シート１").Range("A:A"), ActiveCell.Value)
　　　　If mycount = 0 Then
　　　　　　ActiveCell.Offset(1, 0).Select

>>956　VBAでやる場合

Sub 選択範囲ゼロ削除()

　Dim R As Integer, C As Integer
　Dim irows As Integer, icols As Integer

　R = Selection.Rows.Count
　C = Selection.Columns.Count

　　For irows = R To 1 Step -1
　　　　For icols = C To 1 Step -1
　　　　　　If Cells(irows, icols).Value = "0" Then
　　　　　　　　Cells(irows, icols).Delete Shift:=xlToLeft
　　　　　　End If
　　　　Next icols
　　Next irows

End Sub

>>956
Sheet1A1基点アクティブセル領域→Sheet2A1基点ということなら、965で書いたコードの前半に、
コピー貼り付けするコードが必要だった。

Sub シート2にコピーしてゼロ削除()

　　Dim R As Integer, C As Integer
　　Dim irows As Integer, icols As Integer

　　Worksheets("Sheet1").Range("A1").CurrentRegion.Copy Worksheets("Sheet2").Range("A1")
　　Worksheets("Sheet2").Activate
　　Range("A1").CurrentRegion.Select

　　R = Selection.Rows.Count
　　C = Selection.Columns.Count

　　For irows = R To 1 Step -1
　　　　For icols = C To 1 Step -1
　　　　　　If Cells(irows, icols).Value = "0" Then
　　　　　　　　Cells(irows, icols).Delete Shift:=xlToLeft
　　　　　　End If
　　　　Next icols
　　Next irows

End Sub

Sheet2にコピーすんならDelete Shiftとかめんどくさいことしないで
普通に0じゃないセルだけ順次コピーしてけばいいんじゃね

【1 OSの種類 　 　 　 　 .】 WindowsＸＰ
【2 Excelのバージョン 　 】 Excel2003
【3 VBAが使えるか　 　 .】 いいえ
【4 VBAでの回答の可否】 否

縦のセル(Ａ行)に２/8〜４/1まで日付を入力したいんですが、
手打ちで入力するのが面倒なのです。
Ａ行に、２/8、２/9、2/10・・・と自動で一日ずつ日付を表示させるには、どうすればいいんでしょうか。

>>968
A1に2/8って入れてセルの右下あたりでマウス左ボタンを押し下げてそのまま下方向にドラッグ

【1 OSの種類 　 　 　 　 .】 WindowsＸＰ
【2 Excelのバージョン 　 】 Excel2002
【3 VBAが使えるか　 　 .】 はい
【4 VBAでの回答の可否】 可
【5 検索キーワード 　 　 】 Excel フォーム サイズ変更

VBAでユーザーフォームの最大化・最小化ボタンを表示したり端っこをドラッグしてリサイズしたり
することはできませんか。
ちょっと探したんだけど、キーワードが悪いのかどうも見つからない・・・

>>956
こんなのはいかがでしょうか。^^
但し、対象範囲に元々空白セルは無いという前提です。

Sub ゼロセル削除()
　　Dim rngOrg As Range
　　Dim rngResult As Range
　　
　　Set rngOrg = Worksheets("Sheet1").Range("A1").CurrentRegion
　　Set rngResult = Worksheets("Sheet2").Range("A1")
　　
　　rngResult.Worksheet.UsedRange.ClearContents
　　rngOrg.Copy rngResult
　　Set rngResult = rngResult.CurrentRegion
　　
　　rngResult.Replace What:="0", Replacement:="", LookAt:=xlWhole
　　Set rngResult = rngResult.SpecialCells(xlCellTypeBlanks)
　　rngResult.Delete xlToLeft
End Sub

>>969
VBAのフォームで、そもそもボタンがtitle-barに乗ってこないから、
ActiveXコンポーネントでもないんじゃないかなと思う。
VBA　フォーム　サイズ変更
で検索掛けてみたけど、やっぱりVB6とか2005じゃないと無理なのかなあ。

>>963
たびたび申し訳ございません。
試してみたのですが、またシート1を削除してしまいます。

シート１　　　　　　シート２
0000 0000←消す
0001 0001←消す
0004 0002←消さない
0006 0003←消さない
0009 0004←消す
0005←消さない
0006←消す
0007←消さない
0008←消さない
0009←消す
0010←消さない

といった形です。言葉足らずで申し訳ございません。

表示が崩れてしまいましたΣ(;￣□￣Ａ
消す・消さないの指している数字はシート2にあるものです。
シート1には
0000
0001
0004
0006
0009
がＡ：Ａに入っています。

API使ってどうにかできました。最大化、最小化、サイズ変更境界とも設定可能でした。
スクリプトはると長いので（そんなに長くもないけど）、参考サイトだけ。

ttp://excelfactory.net/excelvbatips/api/api_index.html
ttp://yokohama.cool.ne.jp/chokuto/urawaza/api/SetWindowLong.html

>>961
TEIOUさんの改良版です
>>963はシート２で実行すれば動きますよ。

Sub 削除()
　Application.ScreenUpdating = False
　a = Array("A", "G", "M")
　Sheets("シート２").Range("A1").Select
　i = 1
　Do
　　For n = 0 To 2
　　　Cells(i, a(n)).Select
　　　mycount = Application.WorksheetFunction.CountIf(Sheets("シート１").Range("A:A"), ActiveCell.Value)
　　　If mycount > 0 Then
　　　　Selection.ClearContents
　　　End If
　　Next
　　i = i + 1
　　If Cells(i, a(0)) = "" And Cells(i, a(1)) = "" And Cells(i, a(2)) = "" Then
　　　Exit Do
　　End If
　Loop
　Application.ScreenUpdating = True
End Sub

Sheets("シート２").Range("A1").Select
　↓
Sheets("シート２").Select
Range("A1").Select
に訂正

>962>965>966>967>970

皆さん、ありがとうございます。

参考にさせて戴きました。

>>877ですが、変わる値を全てどこかに書き出せますか？

>>978
意味不明だから却下。値って何の値だよ
とりあえずテンプレ熟読しろ

あらかじめ貼っておくか

>>3
> 指摘されてから書き直しても、その質問にはまともな回答が付かないと思ってください。

>>951さん、ありがとうございました！
初ＶＢＡでしたが、何とかできました。

>>979

＞978
は私ではありません。

テンプレテンプレと鵜材わりには役に立たない奴は放っておいて、
みゆきｻﾝ　まだ居ますかね？少しは早くなると思います。

For i = 1 To 84
　 If Cells(lRow, i) <> "" Then
　 　 For ii = i + 1 To 85
　 　 　 If Cells(lRow, ii) <> "" Then Cnt_01(i, ii) = Cnt_01(i, ii) + 1
　 　 Next ii
　 End If
Next i

>>963
>>975
有り難うございます。無事動作しました。
お手数お掛けして申し訳ございませんでした。

次スレ待ち保守

えっ!?
次スレって、これじゃないの？
http://pc8.2ch.net/test/read.cgi/bsoft/1143177051/

>>986
立ってたのですね…失礼しました埋め

保守ウメ