Excel VBA質問箱 IV

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

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


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

5 / 3840 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【82372】Re:D列において括弧がついているデータの...

すぺぺぺ - 24/10/1(火) 10:12 -


	引用なし

	パスワード

▼マナ様：

ご教授ありがとうございます！
分割を行いたい内容でしたが、抽出も併せて今後の参考にさせていただきます。
お忙しいところありがとうございました。

・ツリー全体表示


	【82371】Re:D列において括弧がついているデータの...

マナ - 24/10/1(火) 9:10 -


	引用なし

	パスワード

▼すぺぺぺさん：

抽出ではなく、分割だったか？

Sub test()
　　Dim v, k As Long
　　Dim s As String, n As Long
　
　　With Range("A1", ActiveSheet.UsedRange).Offset(1).Resize(, 4)
　　　　v = .Value
　　　　For k = 1 To UBound(v)
　　　　　　s = v(k, 4)
　　　　　　If s Like "?*[（(]?*[）)]" Then
　　　　　　　　n = InStr(Replace(s, "（", "("), "(")
　　　　　　　　v(k, 1) = Mid(s, n)
　　　　　　　　v(k, 4) = Left(s, n - 1)
　　　　　　End If
　　　　Next
　　　　.Value = v
　　End With

End Sub

・ツリー全体表示


	【82370】Re:D列において括弧がついているデータの...

マナ - 24/9/30(月) 21:33 -


	引用なし

	パスワード

▼すぺぺぺさん：

Sub test()
　　
　　With Range("A1", ActiveSheet.UsedRange).Offset(1).Columns(1)
　　　　.FormulaR1C1 = "=if(rc[3]="""","""",Getカッコデータ(rc[3]))"
　　　　.Value = .Value
　　End With

End Sub

Function Getカッコデータ(ByVal 元テキスト As String) As String
　
　　元テキスト = Replace(元テキスト, "（", "(")
　　元テキスト = Replace(元テキスト, "）", ")")

　　Dim 開始 As Long, 終了 As Long
　　開始 = InStr(元テキスト, "(")
　　終了 = InStrRev(元テキスト, ")")
　
　　If 開始 > 1 And 終了 >= 開始 Then
　　　　Getカッコデータ = Mid(元テキスト, 開始, 終了 - 開始 + 1)
　　End If

End Function

・ツリー全体表示


	【82369】D列において括弧がついているデータのみ...

すぺぺぺ - 24/9/30(月) 16:45 -


	引用なし

	パスワード

下記のような条件にて動作をするVBAを作成したいのですがご教示頂けましたら幸いです。
D列においてランダムで、商品名（SHOUHINMEI）というデータがある場合のみ括弧を含めた括弧内の文字データのみをA列に改行したいのですが…
元データ→D列商品名（SHOUHINMEI）
VBA実施後のデータ→D列　商品名、A列（SHOUHINMEI）

A列での同じような動作は下記のコードで実施できております。

Sub A列を取得()
　　Application.ScreenUpdating = False

　　Dim R As Long
　　For R = 2 To Get最終行(ActiveSheet)
　　　　If Cells(R, 1) <> "" Then
　　　　　　Cells(R, 2) = Getカッコ内(Cells(R, 1))
　　　　End If
　　Next
　　
End Sub

Function Getカッコ内(ByVal 元テキスト As String) As String
　　
　　元テキスト = Replace(元テキスト, "（", "(")
　　元テキスト = Replace(元テキスト, "）", ")")

　　Dim 開始 As Long, 終了 As Long
　　開始 = InStr(元テキスト, "(") + 1
　　終了 = InStr(元テキスト, ")") - 1
　　
　　If 開始 > 1 And 終了 >= 開始 Then
　　　　Getカッコ内 = Mid(元テキスト, 開始, 終了 - 開始 + 1)
　　End If

End Function
　　' シートの最終行を取得する
　　Function Get最終行(ws As Worksheet) As Long
　　Get最終行 = ws.UsedRange.Rows.Count + ws.UsedRange.Row - 1
　　
End Function

・ツリー全体表示


	【82368】Re:外部データが最終行まで読み込まれな...

jindon - 24/9/29(日) 12:52 -


	引用なし

	パスワード

ADO接続で読み込み Sub ボタン1_Click() 　　Dim wsDest As Worksheet 　　Dim lastRow As Long 　　Dim filePath As String 　　' ファイルダイアログを使用してファイルを選択　　With Application.FileDialog(msoFileDialogOpen) 　　　　.Title = "Select the Excel file" 　　　　.Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls" 　　　　.AllowMultiSelect = False 　　　　If .Show = -1 Then 　　　　　　filePath = .SelectedItems(1) 　　　　Else 　　　　　　MsgBox "ファイルが選択されていません。" 　　　　　　Exit Sub 　　　　End If 　　End With 　　　　' 勘定科目シートの存在を確認　　On Error Resume Next 　　Set wsDest = ThisWorkbook.Sheets("勘定科目") 　　On Error GoTo 0 　　　　If wsDest Is Nothing Then 　　　　MsgBox "シート '勘定科目' が見つかりません。シート名を確認してください。" 　　　　Exit Sub 　　End If 　　'勘定科目シートのA:Z列の最終行を取得　　With Intersect(wsDest.UsedRange, wsDest.Columns("a:z")) 　　　　lastRow = wsDest.Evaluate("max(if(" & .Address & "<>"""",row(" & .Address & ")))") 　　End With 　　　　' 外部ファイルのシート名を取得する　　Dim wsName$ 　　With CreateObject("DAO.DBEngine.120").workspaces(0).OpenDatabase(filePath, True, True, "excel 12.0;HDR=No;") 　　　　wsName = Replace(.tabledefs(0).Name, "'", "") 　　　　wsName = Left$(wsName, Len(wsName) - 1) 　　　　.Close 　　End With 　　　　' 外部ファイルをDatabaseとして接続する　　Dim s$ 　　s = "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & filePath & _ 　　　　　　";Extended Properties='Excel 12.0;HDR=No';" 　　With CreateObject("ADODB.Recordset") 　　　　.Open "Select * From `" & wsName & "$A3:Z`", s 　　　　wsDest.Cells(lastRow + 1, 1).CopyFromRecordset .DataSource 　　End With 　　MsgBox "データのコピーが完了しました。" End Sub

・ツリー全体表示


	【82367】Re:外部データが最終行まで読み込まれな...

マナ - 24/9/21(土) 19:20 -


	引用なし

	パスワード

▼GAO さん：

sourceLastRow は、A列最終行なのに
lastRow は、E～Z列の最終行ですが何故ですか

・ツリー全体表示


	【82366】外部データが最終行まで読み込まれない。

GAO

- 24/9/20(金) 9:42 -


	引用なし

	パスワード

外部のExcelデータを
コピー先のExcelに全コピーします。

コピー元の３行目から最終行までコピーします
コピー先は、A列からZ列にある文字の最後より下に
コピー元のデータを張りつけています。
コードを書いたのですが、コピー元の６行目までしかコピーされず
原因がわからない状態です。
教えて頂けないでしょうか。

Sub ボタン1_Click()
　　Dim wsDest As Worksheet
　　Dim lastRow As Long
　　Dim nextRow As Long
　　Dim i As Long, j As Long
　　Dim wbSource As Workbook
　　Dim wsSource As Worksheet
　　Dim filePath As String
　　Dim sourceLastRow As Long
　　Dim sourceLastCol As Long

　　' ファイルダイアログを使用してファイルを選択
　　With Application.FileDialog(msoFileDialogOpen)
　　　　.Title = "Select the Excel file"
　　　　.Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls"
　　　　.AllowMultiSelect = False
　　　　If .Show = -1 Then
　　　　　　filePath = .SelectedItems(1)
　　　　Else
　　　　　　MsgBox "ファイルが選択されていません。"
　　　　　　Exit Sub
　　　　End If
　　End With

　　' 外部ファイルを開く
　　Set wbSource = Workbooks.Open(filePath)

　　' 1番目のシートを設定
　　Set wsSource = wbSource.Sheets(1) ' 1番目のシートを使用

　　' 勘定科目シートの存在を確認
　　On Error Resume Next
　　Set wsDest = ThisWorkbook.Sheets("勘定科目")
　　On Error GoTo 0

　　If wsDest Is Nothing Then
　　　　MsgBox "シート '勘定科目' が見つかりません。シート名を確認してください。"
　　　　wbSource.Close False
　　　　Exit Sub
　　End If

　　' 勘定科目シートのE列からZ列までの最終行を確認
　　lastRow = 0
　　For j = 5 To 26 ' E列からZ列まで
　　　　If wsDest.Cells(wsDest.Rows.Count, j).End(xlUp).Row > lastRow Then
　　　　　　lastRow = wsDest.Cells(wsDest.Rows.Count, j).End(xlUp).Row
　　　　End If
　　Next j

　　' 次にデータを入力する行を設定
　　If wsDest.Cells(lastRow, 5).Value <> "" Then
　　　　nextRow = lastRow + 1
　　Else
　　　　nextRow = lastRow
　　End If

　　' 外部ファイルの最終行と最終列を取得
　　sourceLastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
　　sourceLastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column

　　' データをコピー（3行目から最終行まで、A列からZ列まで）
　　For i = 3 To sourceLastRow
　　　　For j = 1 To 26 ' A列からZ列まで
　　　　　　wsDest.Cells(nextRow, j).Value = wsSource.Cells(i, j).Value
　　　　Next j
　　　　nextRow = nextRow + 1
　　Next i

　　' 外部ファイルを閉じる
　　wbSource.Close False

　　MsgBox "データのコピーが完了しました。"
End Sub

・ツリー全体表示


	【82365】PDFに一括で個別パスワードを設定

PDF - 24/9/10(火) 9:33 -


	引用なし

	パスワード

500ファイルほどのPDFに個別でパスワードを設定したいです。
PDFのアクションウィザードでは、
同じパスワードでの設定はできたのですが、
個別にパスワードを設定したいので、
やり方をご存知でしたらご教示ください。
印刷可
変更はパスワードをかけたいです。
よろしくお願いします。

・ツリー全体表示


	【82364】Re:カウント数分の行を別シートに挿入し...

ぺろ - 24/9/5(木) 9:27 -


	引用なし

	パスワード

▼マナさん：

ご教示ありがとうございます。
書籍等で調べても参考となるものが無く困っておりました。
教えていただいた関数で無事動作しました。
ありがとうございました。

・ツリー全体表示


	【82363】Re:カウント数分の行を別シートに挿入し...

マナ - 24/9/5(木) 8:24 -


	引用なし

	パスワード

▼ぺろさん：

Sub test()
　　 Dim n As Long
　　 s
　　 n = Sheets("sheet2").Range("A2").Value
　　 If n > 0 Then Sheets("Sheet1").Rows(挿入先の行暗号).Resize(n).Insert
　　
End Sub

・ツリー全体表示


	【82362】カウント数分の行を別シートに挿入したい

ぺろ - 24/9/3(火) 18:37 -


	引用なし

	パスワード

以下内容でご教授いただきたく質問させていただきます。

行いたい事
シート２のセルA2にカウント関数で数量をカウント、
シート２でカウントした数をシート１へ行として挿入を行う。

カウント関数以降の手段が思いつかない為質問させていただきました。
仕様に関してアドバイスの程、よろしくお願いいたします。

・ツリー全体表示


	【82361】Re:コピーしたデータを空白セルに追加し...

すぺぺぺ - 24/8/27(火) 10:58 -


	引用なし

	パスワード

▼マナ様：

ご教授頂きましたデータを使用したところ思った通りの動作となりました！
ありがとうございました。

・ツリー全体表示


	【82360】Re:コピーしたデータを空白セルに追加し...

マナ - 24/8/26(月) 22:09 -


	引用なし

	パスワード

▼すぺぺぺさん： >'ws2の貼り付け位置 >x = ws2.Range("A1").End(xlDown).Row >If x = Rows.Count Then x = 1 Else x = x + 1 入力済みデータの個数をカウントしてはどうでしょうか x = WorksheetFunction.CountA(ws2.Columns("A")) + 1

・ツリー全体表示


	【82359】コピーしたデータを空白セルに追加してい...

すぺぺぺ - 24/8/26(月) 21:12 -


	引用なし

	パスワード

下記内容ご教授頂けましたら幸いです。

データの転記を行いたいのですが、コピー先のシートへの転記が思ったように行えず質問させて頂きました。
コピー先の貼り付け位置の取得がうまくできず、数値入力が行えているセルに数値が上書きされてしまう状態です。
データを転記する度に下段のセルにデータが入力されるようにしたいのですが、WS2の貼り付け位置の指示をどのように行えば思ったように入力されるでしょうか。

Sub データ転記()
'シートを変数にセット
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Worksheets("コピー元")
Set ws2 = Worksheets("コピー先")

'ws2の貼り付け位置
x = ws2.Range("A1").End(xlDown).Row
If x = Rows.Count Then x = 1 Else x = x + 1

ws1.Range("H3").Copy
ws2.Range("A" & x).PasteSpecial xlPasteValues

ws1.Range("B3").Copy
ws2.Range("B" & x).PasteSpecial xlPasteValues

ws1.Range("C15").Copy
ws2.Range("C" & x).PasteSpecial xlPasteValues

'コピー指定解除
　　Application.CutCopyMode = False

End Sub

・ツリー全体表示


	【82358】Re:ピボットテーブルを別シートに転記

かずこ - 24/8/26(月) 10:16 -


	引用なし

	パスワード

▼マナさん：
>▼かずこさん：
>
>貼り付け先に、ピボットテーブルが存在していませんか

ご返信ありがとうございます。

すみません、ピボットテーブルの削除を繰り返し処理に変えてみたところうまく動作しました。

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

・ツリー全体表示


	【82357】Re:ピボットテーブルを別シートに転記

マナ - 24/8/23(金) 18:26 -


	引用なし

	パスワード

▼かずこさん：

貼り付け先に、ピボットテーブルが存在していませんか

・ツリー全体表示


	【82356】ピボットテーブルを別シートに転記

かずこ

- 24/8/23(金) 14:18 -


	引用なし

	パスワード

ピボットテーブルの別シートへのコピー＆ペーストで苦戦しています。
下記コードを実行するとエラーで'1004'「ピボットテーブルに影響するため、選択したセルに対してこの変更を行うことができません。レポートを～」がでます。
お手数をおかけしますがいいコードがあればご教示お願いいたします。

Worksheets(2).PivotTables(1).TableRange2.Copy Worksheets(1).Range("B27")

・ツリー全体表示


	【82355】Re:セル内重複文字削除

マクロ勉強中です。。 - 24/8/21(水) 20:18 -


	引用なし

	パスワード

▼マナさん：

正常に動作致しました。
長々とお付き合いいただき、ありがとうございました！

・ツリー全体表示


	【82354】Re:セル内重複文字削除

マナ - 24/8/20(火) 19:49 -


	引用なし

	パスワード

▼マクロ勉強中です。。さん：

Sub test5()
　　Dim r As Range, c As Range
　　Dim v() As String, e
　　Dim s1 As String, s2 As String, s3 As String
　　Dim n As Long
　　
　　If TypeName(Selection) <> "Range" Then Exit Sub
　　Set r = Selection
　　If r.Columns.Count > 1 Then Exit Sub
　　If WorksheetFunction.CountA(r) = 0 Then Exit Sub
　　
　　ReDim v(1 To r.Count, 1 To 1)
　　
　　For Each c In r
　　　　For Each e In Split(c.Value, "　")
　　　　　　s2 = "　" & e & "　"
　　　　　　If InStr(s1, s2) = 0 Then
　　　　　　　　s1 = s1 & s2
　　　　　　　　s3 = s3 & "　" & e
　　　　　　End If
　　　　Next
　　　　If Len(s3) > 0 Then
　　　　　　n = n + 1
　　　　　　v(n, 1) = Mid(s3, 2)
　　　　　　s3 = ""
　　　　End If
　　Next

　　r.Value = v
　　
End Sub

・ツリー全体表示


	【82353】Re:セル内重複文字削除

マクロ勉強中です。。 - 24/8/20(火) 12:55 -


	引用なし

	パスワード

▼マナさん：

最近MacBookにPCを変えたのですが、
WindowsのPCで試してみたところ、エラー表示なく動作はしたのですが、
重複している文字が消えずに、選択したセルの右横のセルに入力されている文字が消えてしまいました。

・ツリー全体表示


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

5 / 3840 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free