Excel VBA質問箱 IV

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

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


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

2 / 3837 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【82385】Re:複数のエクセルブックからデータを取...

ぺろ - 24/10/9(水) 16:32 -


	引用なし

	パスワード

▼マナさん：

説明が下手で申し訳ありません。
値の上書きを行う状態ではなく、空白セルを取得しそこに値を追加していく形で全ての値を保持して１つのブックとしてまとめていければと思っております。

・ツリー全体表示


	【82384】Re:複数のエクセルブックからデータを取...

マナ - 24/10/9(水) 15:39 -


	引用なし

	パスワード

▼ぺろさん：

転記元のブックが２つ以上あったとして、
同じセルにデータが入力されていると、
あとから転記した値で上書きされてしまいますが
問題ないのでしょうか

・ツリー全体表示


	【82383】複数のエクセルブックからデータを取得し...

ぺろ - 24/10/9(水) 10:25 -


	引用なし

	パスワード

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

行いたい事
転記先シートB3（開いているブック）に入力されている文字が保存名にあるxlsmファイルを検索して開く。
一致するファイルがある場合セルA18～E38の間のデータが入力されている部分のみをコピーし転記先シートのA18～E38セルへコピー。
転記元ファイル数、転記データの行数が異なる為、転記時に転記先シートのデータがないセルにコピーを行う。
一致するファイルがなくなるまで以上の処理を繰り返す。

ファイルの検索方法、データの貼り付け位置指定の手段が思いつかない為質問させていただきました。
仕様に関してアドバイスの程、よろしくお願いいたします。

Sub データ収集()

　　Dim FolderPath As String, Filename As String, ws As Worksheet

　　　　' 転記元ファイルがあるフォルダのパスを指定
　　FolderPath = ("転記元フォルダ")

　　　　' 拡張子が.xlsmのファイルを検索
　　Filename = Dir(FolderPath & "*.xlsm")
　　　　
　　While Filename <> ""
　　　　Workbooks.Open FolderPath & Filename　' 転記元ファイルを開く
　　　　For Each ws In ActiveWorkbook.Sheets(1)　' 転記元のシートを指定
　　　　　　ws.UsedRange.Copy ThisWorkbook.Sheets(DB).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)　' 転記先のシートを指定
　　　　Next ws
　　　　Workbooks(Filename).Close SaveChanges:=False
　　　　Filename = Dir
　　Wend

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

End Sub

・ツリー全体表示


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

すぺぺぺ - 24/10/5(土) 19:05 -


	引用なし

	パスワード

▼マナ様

大変お手数おかけいたしました。
教えていただきましたコードで問題なく動作しておりました。

エラーが出てしまった原因として、コードを眺めていた際に余計なキーを押してしまっており、文字が入力されてしまっていた事が原因でした。

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

・ツリー全体表示


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

すぺぺぺ - 24/10/5(土) 15:46 -


	引用なし

	パスワード

▼マナ様

先ほど添付していただいたデータではエラー無く思った通りの動作をしておりました。
実際に使うデータにて改めて試してみます。

・ツリー全体表示


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

マナ - 24/10/5(土) 8:51 -


	引用なし

	パスワード

▼すぺぺぺさん：

まずは下記データで試してみてください

　　 A　　B　　C　　D
１
２　あ　い　う　　え(いろは)
３　１　２　　３　４

　　　

・ツリー全体表示


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

すぺぺぺ - 24/10/5(土) 2:57 -


	引用なし

	パスワード

▼マナ様

コピペしてそのまま使用させて頂いております。
動作環境のソフトはOffice 2019です。

・ツリー全体表示


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

マナ - 24/10/4(金) 23:22 -


	引用なし

	パスワード

▼すぺぺぺさん：

コピペして、そのまま使用していますか。
それとも、どこか修正していますか。

・ツリー全体表示


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

すぺぺぺ - 24/10/4(金) 22:18 -


	引用なし

	パスワード

▼マナ様

早速のご返答ありがとうございます。
最終行のコード
r.Resize(a.Count).Value = Application.Index(a.toarray, 0, 0)　ここの部分にて型が一致しませんとエラーがでてしまうのですが、記載ミス等ございますでしょうか

・ツリー全体表示


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

マナ - 24/10/4(金) 22:02 -


	引用なし

	パスワード

▼すぺぺぺさん：

Sub test2()
　　Dim a As Object
　　Dim r As Range
　　Dim w, v, k As Long
　　Dim s As String, n As Long

　　Set a = CreateObject("system.collections.arraylist")
　　
　　Set r = Range("A1", ActiveSheet.UsedRange).Offset(1).Resize(, 4)
　　w = r.Value
　　For k = 1 To UBound(w)
　　　　v = Application.Index(w, k, 0)
　　　　a.Add v
　　　　s = v(4)
　　　　If s Like "?*[（(]?*[）)]" Then
　　　　　　n = InStr(Replace(s, "（", "("), "(")
　　　　　　v(4) = Left(s, n - 1)
　　　　　　a(a.Count - 1) = v
　　　　　　a.Add Array(Mid(s, n), Empty, Empty, Empty)
　　　　End If
　　Next
　　r.Resize(a.Count).Value = Application.Index(a.toarray, 0, 0)

End Sub

・ツリー全体表示


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

すぺぺぺ - 24/10/4(金) 16:13 -


	引用なし

	パスワード

▼マナ様

度々申し訳ありません。
改行ではなく挿入の伝え間違えです。
元のデータの下段にセルを挿入し、挿入したA列のセルにDから分割したデータの移動が行いたいのですが…

お返事いただいたコードを実行し、使用したい部位の移動はできるのは確認いたしましたが、改行コードに変更したところうまく動作しない為ご返信させて頂きました。

・ツリー全体表示


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

マナ - 24/10/4(金) 10:06 -


	引用なし

	パスワード

▼すぺぺぺさん：

v(k, 1) = v(k, 1) & vbLf & Mid(s, n)

・ツリー全体表示


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

すぺぺぺ - 24/10/3(木) 19:47 -


	引用なし

	パスワード

▼マナ様

説明不足で申し訳ありません。
先日教えて頂きました分割のコードにて教えて頂きたい事があり書き込みさせて頂きます。

セルA～Dの1,2行に下記のようなデータが入力されております。
A　　B　　C　　D
１　あ　い　う　え(いろは)
２　１　２　３　４

教えて頂いたコードを実行すると括弧内の文字は移動はするのですが改行は行われず、
セルAのデータが消えセルDの括弧部分と置き換わり下記の状態になってしまいます。
　A　　　　B　　C　　D
１(いろは)　い　う　え
２　１　　　２　　３　４

VBA実行後にD列の括弧を含め、D列の文字をA列に改行し挿入する場合はどのようにすればよいでしょうか。
以下のような状態の並びにしたいのですが・・・
　 A　　B　　C　　D
１　あ　い　う　え
２(いろは)
３　１　２　３　４

・ツリー全体表示


	【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

・ツリー全体表示


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

2 / 3837 ﾍﾟｰｼﾞ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free