Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

290 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【76631】Re:ユーザフォーム最小化釦について

β - 15/2/20(金) 20:30 -


	引用なし

	パスワード

▼コマちゃんさん：

こんばんは

とりあえず Declare と Function の間に PtrSafe を加えてみてください。

・ツリー全体表示


	【76630】ユーザフォーム最小化釦について

コマちゃん

- 15/2/20(金) 18:37 -


	引用なし

	パスワード

windows-XP使用時に最小化釦として下記コードを使用していました。
'ユーザーーフォーム最小化釦付記
Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
　　(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
　　(ByVal hwnd As Long, ByVal nIndex As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
　　(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long

処がwindows8.1になり64ビットシステムになり、
Declareステートメントの更新エラーとなります。
如何どのように処置すればよいでしょうか？

・ツリー全体表示


	【76629】Re:セル内の文字の一部を除去

カリーニン - 15/2/19(木) 23:24 -


	引用なし

	パスワード

↑のコードは文字色のみ考慮したもので不備がありました。
文字色、太文字、斜字体の３点を考慮した改造版です。

Sub test()
Dim mycell As Range
Dim sagyoucell As Range
Dim cellstr As String
Dim i As Long
Dim j As Long
　Set sagyoucell = ActiveSheet.Cells(1, 1)
　Set mycell = ActiveCell
　cellstr = ""
　For i = 1 To Len(mycell.Value)
　 If i < 2 Or i > 2 + 2 - 1 Then cellstr = cellstr & Mid(mycell.Value, i, 1)
　Next i
　With sagyoucell
　 .NumberFormatLocal = "@"
　 .Value = cellstr
　End With
　j = 0
　For i = 1 To Len(mycell.Value)
　 If i < 2 Or i > 2 + 2 - 1 Then
　　　j = j + 1
　　　With sagyoucell.Characters(Start:=j, Length:=1).Font
　　　 .Color = mycell.Characters(Start:=i, Length:=1).Font.Color
　　　 .Bold = mycell.Characters(Start:=i, Length:=1).Font.Bold
　　　 .Italic = mycell.Characters(Start:=i, Length:=1).Font.Italic
　　　End With
　 End If
　Next i
　sagyoucell.Copy mycell
　sagyoucell.Clear
　Set sagyoucell = Nothing
　Set mycell = Nothing
End Sub

・ツリー全体表示


	【76628】Re:セル内の文字の一部を除去

カリーニン - 15/2/19(木) 23:17 -


	引用なし

	パスワード

>>Range("A1") = Left(Range("A1"), 1) & Mid(Range("A1"), 4)

>作業セルを使わないで同じセルで作業するとセルの文字数とループの数が合わなくなりますよ。

よく見たらループ作業では無かったですね。失礼しました。

・ツリー全体表示


	【76627】Re:セル内の文字の一部を除去

カリーニン - 15/2/19(木) 23:15 -


	引用なし

	パスワード

>Range("A1") = Left(Range("A1"), 1) & Mid(Range("A1"), 4)

作業セルを使わないで同じセルで作業するとセルの文字数とループの数が合わなくなりますよ。

とりあえず、の案です。
他の回答者からもっとマシなレスが付くまでの繋ぎです。

Sub test1()
Dim mycell As Range
Dim sagyoucell As Range
Dim cellstr As String
Dim i As Long
Dim j As Long
　Set sagyoucell = ActiveSheet.Cells(1, 1)
　Set mycell = ActiveCell
　cellstr = ""
　For i = 1 To Len(mycell.Value)
　 If i < 2 Or i > 2 + 2 - 1 Then cellstr = cellstr & Mid(mycell.Value, i, 1)
　Next i
　With sagyoucell
　 .NumberFormatLocal = "@"
　 .Value = cellstr
　End With
　j = 0
　For i = 1 To Len(mycell.Value)
　 If i < 2 Or i > 2 + 2 - 1 Then
　　　j = j + 1
　　　sagyoucell.Characters(Start:=j, Length:=1).Font.Color = mycell.Characters(Start:=i, Length:=1).Font.Color
　 End If
　Next i
　sagyoucell.Copy mycell
　sagyoucell.Clear
　Set sagyoucell = Nothing
　Set mycell = Nothing
End Sub

・ツリー全体表示


	【76626】セル内の文字の一部を除去

とら - 15/2/19(木) 11:05 -


	引用なし

	パスワード

いつもお世話になっております。
教えて頂けると助かります。

セル内の文字の一部の除去方法について方法がわかりません。
「1234567890」という文字がA1セルにあったとして、5文字目から太字にしているとします。
A1セルの文字を2文字目から2文字除去したいです。

方法１
Range("A1") = Left(Range("A1"), 1) & Mid(Range("A1"), 4)
上記の方法だと太字が通常文字になってしまうのでＮＧ

方法２
Range("A1").Characters(2, 2).Text = ""
この方法が理想でしたがセル内にある文字数が300以上？ぐらいになると
何故か機能しなくなるのでＮＧ

文字を除去した後に、太字にし直すという方法もあるのですが、仕様的に
この方法は使えません。

他に方法あるでしょうか？
宜しくお願いします。

・ツリー全体表示


	【76625】Re:初心者でごめんなさい。

マナ - 15/2/16(月) 20:50 -


	引用なし

	パスワード

＞ＶＢＡ？マクロ？

気にすることありません。
私は使い分けしていません。

ここは、VBA（マクロ）の掲示板なので、
もし、関数での回答を希望していたのであれば、
他で質問したほうがよかったかも。

ただ、関数でなくても統合と並べ替えの操作でできますよ。
慣れれば、１分もかかりません。
私の回答はそれをマクロの記録をとって叩き台にしています。

統合：
ht　tp://www.eurus.dti.ne.jp/~yoneyama/Excel/tougou.html
並べ替え：
ht　tp://www.oshiete-kun.net/archives/2014/10/2010_2.html

・ツリー全体表示


	【76624】Re:初心者でごめんなさい。

よぽん - 15/2/16(月) 11:14 -


	引用なし

	パスワード

ＶＢＡ？マクロ？

まだ、よくわかっていないので
マクロは入力や操作手順とかを覚えて同じ操作を行うためのものですよね？
マクロでＶＢＡを使うのですか？
ＶＢＡをどこに記入するのかその辺からわかっていません。
すみません。

今私にわかっているのは
セルに　[=・・・・] で関数？
を使う方法ぐらいです。
なので、１の方法は初心者なので私にはできないってことでしょうかね？

ＶＢＡで説明していただいた方法も試したいと思います。

・ツリー全体表示


	【76623】Re:初心者でごめんなさい。

β - 15/2/14(土) 18:37 -


	引用なし

	パスワード

▼よぽんさん：

力技です。

Sub Test()
　　Dim sl As Object
　　Dim v As Variant
　　Dim dic As Object
　　Dim r As Range
　　Dim col As Range
　　Dim c As Range
　　Dim x As Long
　　Dim i As Long
　　
　　Set dic = CreateObject("Scripting.Dictionary")
　　Set sl = CreateObject("System.Collections.SortedList")
　　For Each c In Range("K1").CurrentRegion.Columns(1).Cells
　　　　dic(c.Value) = 0
　　Next
　　
　　Set r = Range("A1", ActiveSheet.UsedRange).Columns("A:F")
　　x = r.Columns.Count
　　For i = 1 To x Step 2
　　　　For Each col In r.Columns(i)
　　　　　　For Each c In col.Cells
　　　　　　　　If Not IsEmpty(c.Value) Then
　　　　　　　　　　sl(c.Value) = sl(c.Value) + c.Offset(, 1).Value
　　　　　　　　　　If dic.exists(c.Value) Then dic(c.Value) = dic(c.Value) + c.Offset(, 1).Value
　　　　　　　　End If
　　　　　　Next
　　　　Next
　　Next
　　
　　ReDim v(0 To sl.Count, 0 To 1)
　　For i = 0 To sl.Count - 1
　　　　v(i, 0) = sl.getkey(i)
　　　　v(i, 1) = sl.getbyindex(i)
　　Next
　　
　　Range("H1").CurrentRegion.ClearContents
　　Range("H1").Resize(sl.Count, 2).Value = v
　　v = dic.items
　　Range("L1").Resize(dic.Count).Value = WorksheetFunction.Transpose(dic.items)
　　
End Sub

・ツリー全体表示


	【76622】Re:初心者でごめんなさい。

マナ - 15/2/14(土) 17:45 -


	引用なし

	パスワード

例えば、統合と並べ替えの機能で可能です。
マクロを使うまでもないと思いますが。

Option Explicit

Sub test()
　　Dim 統合先 As Range, 統合元 As Range

　　Set 統合先 = ActiveSheet.Columns("H:I")
　　Set 統合元 = ActiveSheet.Columns("E:F")

　　統合先.ClearContents
　　
　　With 統合先
　　　　.Consolidate _
　　　　　　Sources:=統合元.Address(ReferenceStyle:=xlR1C1), _
　　　　　　Function:=xlSum, _
　　　　　　TopRow:=False, _
　　　　　　LeftColumn:=True
　　End With
　　
　　With ActiveSheet.Sort.SortFields
　　　　.Clear
　　　　.Add Key:=統合先.Cells(1)
　　End With
　　With ActiveSheet.Sort
　　　　.SetRange 統合先
　　　　.Header = xlNo
　　　　.Apply
　　End With

End Sub

Sub test2()
'
　　Dim 統合先 As Range, 統合元 As Range

　　Set 統合先 = ActiveSheet.Columns("K:L")
　　Set 統合元 = ActiveSheet.Columns("E:F")

　　統合先.Columns(2).ClearContents
　　
　　With 統合先
　　　　.Consolidate _
　　　　　　Sources:=統合元.Address(ReferenceStyle:=xlR1C1), _
　　　　　　Function:=xlSum, _
　　　　　　TopRow:=False, _
　　　　　　LeftColumn:=True
　　End With
　　
End Sub

・ツリー全体表示


	【76621】Re:初心者でごめんなさい。

β - 15/2/14(土) 17:43 -


	引用なし

	パスワード

▼よぽんさん：

こんばんは

少なくとも、２．は関数（SUMIF)で対応できますし、関数エキスパートさんなら
１．も関数処理が可能だと思いますが、ＶＢＡでやりたいということですか？

・ツリー全体表示


	【76620】初心者でごめんなさい。

よぽん - 15/2/14(土) 16:42 -


	引用なし

	パスワード

以下のようなセルデータがあったとします。
入力されている列はA～Fまでです。
　　┌─┬─┬─┬─┬─┬──┬─┬─┬──┬─┬─┬──┐
　　│ A│ B│ C│ D│ E│　F │ G│ H│　I │ J│ K│　L │
┌─┼─┼─┼─┼─┼─┼──┼─┼─┼──┼─┼─┼──┤
│ 1│　│　│　│　│ A│ 0.5│　│ A│ 0.7│　│ A│ 0.7│
├─┼─┼─┼─┼─┼─┼──┼─┼─┼──┼─┼─┼──┤
│ 2│　│　│　│　│　│　　│　│ B│ 0.6│　│ B│ 0.6│
├─┼─┼─┼─┼─┼─┼──┼─┼─┼──┼─┼─┼──┤
│ 3│　│　│　│　│ C│ 0.9│　│ C│ 1.0│　│ C│ 1.0│
├─┼─┼─┼─┼─┼─┼──┼─┼─┼──┼─┼─┼──┤
│ 4│　│　│　│　│　│　　│　│　│　　│　│ D│　0 │
├─┼─┼─┼─┼─┼─┼──┼─┼─┼──┼─┼─┼──┤
│ 5│　│　│　│　│ B│ 0.6│　│　│　　│　│ E│　0 │
├─┼─┼─┼─┼─┼─┼──┼─┼─┼──┼─┼─┼──┤
│ 6│　│　│　│　│ C│ 0.1│　│　│　　│　│ F│　0 │
├─┼─┼─┼─┼─┼─┼──┼─┼─┼──┼─┼─┼──┤
│ 7│　│　│　│　│ A│ 0.2│　│　│　　│　│　│　　│
└─┴─┴─┴─┴─┴─┴──┴─┴─┴──┴─┴─┴──┘

E（名称）とF（値）を検索していきます。

1.Hに名称順に、Iに合計値を表示する。
2.Kに名称の一覧を作成しておき該当する名称の値を表示する。

このような場合どうすればよいのでしょうか？
よろしくお願いします。

・ツリー全体表示


	【76619】Re:結合セルがあるシートを転記してまと...

あおもりVBA - 15/2/11(水) 17:13 -


	引用なし

	パスワード

マナさん：

ご対応頂きありがとうございます。
上記のように変更しましたら、正しく動きました！

本当にありがとうございました。
教えて頂いたコードをこれからじっくり見させて頂いて勉強したいです。
私も早くこのようなコードが書けるようになりたいと思います。

ありがとうございました。

・ツリー全体表示


	【76618】Re:結合セルがあるシートを転記してまと...

マナ - 15/2/11(水) 8:54 -


	引用なし

	パスワード

With .Range("C6:Y" & …
の部分を
With .Range("C6:AL" & …

どうなるか確認してもえますか。

・ツリー全体表示


	【76617】Re:結合セルがあるシートを転記してまと...

あおもりVBA - 15/2/11(水) 8:06 -


	引用なし

	パスワード

マナ様

ご教授ありがとうございます。
早速動かしてみましたが、以下の部分で
「結合されたセルの一部は変更することができません」
と表示されます。
私もサンプルで上記コードを作成している際によくでてきました。
結合セルですと、普通に「.copy」としてもダメなのでしょうか？

>　　　　　　　　　 .Copy dstCel

・ツリー全体表示


	【76616】Re:結合セルがあるシートを転記してまと...

マナ - 15/2/11(水) 0:54 -


	引用なし

	パスワード

動かしていませんので、とんでもない結果かもですが、そのときはごめんなさい。

Sub 統合()
　　Dim ws As Worksheet, dstWs As Worksheet
　　Dim dstCel As Range
　　Dim n As Long, r As Long
　　
　　Set dstWs = Workbooks("統合.xls").Worksheets("まとめ")
　　
　　For Each ws In ThisWorkbook.Worksheets
　　　　If Not ws.Name Like "*不要*" Then
　　　　　 Set dstCel = dstWs.Range("C6").Offset(n)
　　　　　 With ws
　　　　　　　 With .Range("C6:Y" & .Range("M" & .Rows.Count).End(xlUp).Row)
　　　　　　　　　 .Copy dstCel
　　　　　　　　　 r = .Rows.Count
　　　　　　　 End With
　　　　　 End With
　　
　　　　　 With dstCel
　　　　　　　 .Resize(r).Value = .Value
　　　　　　End With
　　　　　　n = n + r
　　　　End If
　　Next

End Sub

・ツリー全体表示


	【76615】結合セルがあるシートを転記してまとめる

あおもりVBA - 15/2/10(火) 22:55 -


	引用なし

	パスワード

VBA初心者ですが、業務で使用することとなり勉強しつつ対応しております。
今回、処理がわからず困っておりまして、ご教授頂けませんでしょうか？

やりたい事はファイルAに同じフォーマットのシートが数十枚あり、そのシートのデータを別のファイル、「統合」ブックの「まとめ」シート（フォーマットはファイルAと全く同じでデータが空のもの）に転記していきたいというものです。ただし、シートには転記不要なものが混じっており、そのシート名の一部には（不要）と記載があります。
データの一部に空欄があるのでまとめシートには一列だけ空欄を埋めたい列があります。
また、シートのフォーマットは結合セルでできており、そこがまた悩んでおります。

・データは6行目から入っている
・データはC6:J6、K6:L6、M6:T6、U6:V6、W6:X6、Y6:AL6の結合されたセルから縦に入っており、下行に同じように結合されています。C7:J7、K7:L7・・・。
・M6:T6の列に入っているデータは空白は無いのですが、他の列は途中に空白もあります。
転記した際に、まとめシートにはC6:J6の列のみ全て空白を埋めたく、どのシートもC6:J6の一行目セルには必ずデータが入っておりますのでそのセルの文字をコピーして最下行まで埋めながらまとめたいです。
・M6:T6のセルのデータのみ全項目入っているので最下行を求める時は、M6を基準にしてみました。
・ファイルAの複数シートのデータを転記したいが、（不要）と一部文字が入ったシート名については転記不要です。
・データは数字、文字です。

本を見ながら、ちぐはぐですがつなぎ合わせたコードが下記のものとなります。
ファイルAのシート全部（不要シートはあるが）を処理する繰り返し処理が上手く出来ず、とりあえず、「青森支店」シート「秋田支店」シートの二つのシートをコピーして貼り付け、C列にはM列に文字が入っていれば一番上の文字と同じ値を入れるとしてみましたが・・。
また、C列の空欄を埋める方法にも苦戦しています。

For Each～を使い、*(不要)*シート以外でループするのだろうとは思うのですがなかなか上手くいかず、助けていただけませんでしょうか。
他サイトを見ましたが、結合セルが邪魔して同じように出来ず・・。

つたないコードですが、ご教授お願いできませんでしょうか。

Sub 統合()

Dim Co, Co2 As Integer
Dim sh As Worksheet
Dim all, Last, Last2,LastN As Integer

ThisWorkbook.Activate
Worksheets("青森支店").Select
Co = Range("M6").End(xlDown).Row
Range("C6:Y" & Co).Select
Selection.Copy

Workbooks("統合.xls").Activate
Worksheets("まとめ").Range("C6:J6").PasteSpecial xlPasteValuesAndNumberFormats

Last = Range("M6").End(xlDown).Row

For all = 1 To Last

If Range("M5").Offset(all).Value <> "" Then
Range("C6").Offset(all - 1).Value = Range("C6:J6").Value

End If
Next

Last = Last + 1

ThisWorkbook.Activate
Worksheets("秋田支店").Select

Co2 = Range("M6").End(xlDown).Row
Range("C6:Y" & Co2).Select
Selection.Copy

Workbooks("統合.xls").Activate
LastN = Range("C6:J6").End(xlDown).Row
Worksheets("まとめ").Range("C6:J6").End(xlDown).Offset(1).PasteSpecial xlPasteValuesAndNumberFormats
Last2 = Range("M6").End(xlDown).Row

For all = 1 To Last2 - Last

If Range("M" & LastN).Offset(all).Value <> "" Then
Range("C" & LastN + 1).Offset(all).Value = Range("C6:J6").End(xlDown).Value

End If
Next

Last2 = Last2 + 1

End Sub

・ツリー全体表示


	【76614】Re:VLOOKUPで一致した場合に特定の数値を...

VBA - 15/2/10(火) 10:52 -


	引用なし

	パスワード

回答して頂いた皆様

ありがとうございました。
非常に助かりました。

・ツリー全体表示


	【76613】Re:VLOOKUPで一致した場合に特定の数値を...

β - 15/2/10(火) 8:39 -


	引用なし

	パスワード

▼vba初心者さん：

関数を使わない処理案です。

Sub test2()
　　Dim sh1 As Worksheet
　　Dim sh2 As Worksheet
　　Dim dic As Object
　　Dim v As Variant
　　Dim i As Long
　　Dim c As Range
　　
　　Set sh1 = ThisWorkbook.Sheets("Sheet1")
　　Set sh2 = Workbooks("Book2.xlsx").Sheets("Sheet1")
　　Set dic = CreateObject("Scripting.Dictionary")
　　
　　'Book2のA列の値を格納
　　
　　For Each c In sh2.Range("A2", sh2.Range("A" & Rows.Count).End(xlUp))
　　　　dic(c.Value) = True
　　Next
　　
　　With sh1.Range("v2", sh1.Range("v" & Rows.Count).End(xlUp))
　　　　'Book1　の U,V列を配列に格納
　　　　v = .Cells.Offset(, -1).Resize(, 2).Value
　　　　'配列内で重複チェック
　　　　For i = LBound(v, 1) To UBound(v, 1)
　　　　　　If dic.exists(v(i, 2)) Then
　　　　　　　　v(i, 1) = 1933
　　　　　　Else
　　　　　　　　v(i, 1) = Empty
　　　　　　End If
　　　　Next
　　　　'Book1に書き戻し
　　　　.Cells.Offset(, -1).Resize(, 2).Value = v
　　End With
　　
End Sub

・ツリー全体表示


	【76612】Re:VLOOKUPで一致した場合に特定の数値を...

β - 15/2/10(火) 6:37 -


	引用なし

	パスワード

▼vba初心者さん：

kanabunさんの投稿で、あぁそうだったのかと理解しました。
同じ行にあるものの比較ではなく、その列にあるかどうかだったんですね。
であれば、kanabunさんの指摘通り MATCH でしょうね。
で、かりに行数が極端に多い場合（10,000行とか）は、数式埋め込みではなく
別の方式がいいかもしれません。

・ツリー全体表示


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

290 / 3841 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free