[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『インポートしたCVSデータを転記するときにある条件のとき2列にしたい』(たけし)
Dim uketsuke As Worksheet Set uketsuke = Worksheets("受付一覧")
Dim z As Long z = uketsuke.Cells(Rows.Count, 1).End(xlUp).Row On Error Resume Next
uketsuke.Select Dim wData(1000, 1000) As String For i = 1 To wsRecCnt wData(i, 1) = Cells(z + i, 1).Row - 1 '管理番号 For A = 2 To colCnt Application.StatusBar = "?H転記中" & A & "/" & colCnt
If wCol(A) <> 0 Then: wData(i, A) = wS.Cells(i + 1, wCol(A)) wData(i, 5) = DateValue(wS.Cells(i + 1, 12) & wS.Cells(i + 1, 13) & "年" & wS.Cells(i + 1, 14) & "月" & wS.Cells(i + 1, 15) & "日") wData(i, 26) = Format(Date, "ge.m.d(aaa)") Select Case Cells(z + i, 20) Case "成績の送付先住所": wData(i, 29) = "実家" Case "証明書の住所": wData(i, 29) = "現住所" Case "" If Cells(z + i, 14) = "" Or Cells(z + i, 14) = "同上" Then wData(i, 29) = "実家" Else wData(i, 29) = "現住所" End If Dim i As Long, Dim textA As String Dim textB As String textA = "教科書" textB = "参考書"
If InStr(wData(i, 39), textA) And InStr(wData(i, 40), textB) > 0 Then
uketsuke.Rows(z).Copy Rows(z + 2) End If End Select wData(i, 30) = 1 wData(i, 31) = tgt Next
Next
インポートしたデータを転記するときに転記先(uketsuke)の39セルに「教科書」40セルに「参考書」両方入っているとき同じものを下にコピーして2列にしたい。
↑のままだと転記前の最終行がコピーされて同じデータが入らないです。
< 使用 Excel:Excel2016、使用 OS:Windows10 >
上記のようにインポートしたデータを受付一覧シートに転記する際、使用前には順番通りに転記され、使用後にまったく同じものをコピーしたいです。
csvデータは複数読み込みできる仕様になっていますので出来れば複数読み込みしたときにも反映してほしいですが、1個ずつの読み込みでしか出来なくても問題はないです。
(たけし) 2022/12/05(月) 15:21:11
>↑のままだと転記前の最終行がコピーされて同じデータが入らないです。
コンパイルエラーになるので、動作しないはずですが。
>基盤は他の方が組んでいて、私は追加でコピーするシステムを組み込みたいのですが、基盤を組んだ人はいな >くなってしまったので聞けないのです。 >私自身は基本程度の知識しかなく、色々調べて試しましたができなかったので、教えていただきたいです。
wDataを張り付けているコードがあるはずなので、 その後に、データを判定して挿入やら貼付けやらを行う、という手があります。
業務でのことかと思いますが、分からないのであれば、 業者依頼も検討に入れましょう。 それでも貴方が作る必要なあるなら、作れるスキルを身に付けることも 業務なのではないですか?
(tkit) 2022/12/05(月) 15:37:36
Dim fn As Variant '取り込むCSVファイル名を指定 fn = Application.GetOpenFilename(FileFilter:="CSVファイル(*.csv),*.csv", _ title:="CSVファイルの選択") If fn = False Then Application.StatusBar = False Exit Sub End If Application.StatusBar = "?ACSVファイル名取得"
'指定したCSVが取込済か否か検証する。 取込済ファイルは二重取込防止のためオミット処理
Dim PathName As String, FileName As String, Ypos As Long Ypos = InStrRev(fn, "\") PathName = Left(fn, Ypos) FileName = Mid(fn, Ypos + 1) '?@で選択したcsvのファイル名のみを取得 Sheets("備考").Range("Defaultfolder.CurrentDirectory") = PathName 'シート「備考」の「Defaultfolder.CurrentDirectory」欄に最新のCSVのフォルダパスを転記 Sheets("CSVログ").Select
Dim i As Long, A As Long, B As Long, C As Long, CSVログLastRow As Long ImportHistrylastRow = Sheets("CSVログ").Cells(Rows.Count, 2).End(xlUp).Row
For i = 1 To ImportHistrylastRow If Cells(i, 2) = FileName Then MsgBox "選択されたファイル:[ " & FileName & " ]は、" & vbNewLine & _ Cells(i, 3) & " にインポート済みです。処理を中断します。", vbCritical + vbOKOnly Application.ScreenUpdating = True Sheets("受付一覧").Select Exit Sub Else End If Next
Application.StatusBar = "?BCSVファイル重複エクスポートチェック"
'★?A指定したCSVを開いて、作業用シートに貼付
Dim wS As Worksheet Set wS = Worksheets("CSVインポート") '作業用シートの定義
wS.Cells.Clear '取込みシートを一旦全てクリアにする wS.Select
Dim v(255) As Long 'TextFileColumnDataTypes で全項目を文字列指定用するための処理 For i = 0 To 255 v(i) = 2 'xlTextFormat Next Application.StatusBar = "?Cテキスト形式に変換"
'CSVファイルの読み込み Dim qt As QueryTable Set qt = wS.QueryTables.Add(Connection:="TEXT;" & fn, Destination:=wS.Range("A1"))
Application.StatusBar = "?Dcsvをクエリテーブルで一括取込、"
With qt .TextFileParseType = xlDelimited '文字で区切った形式 .TextFileCommaDelimiter = True '区切り文字はカンマ .TextFileColumnDataTypes = Array(v) '文字列指定 .RefreshStyle = xlOverwriteCells '上書きを指定 .Refresh '上書き .Delete '切断 End With
Dim wsRecCnt As Long 'コピーしたcsvの件数を取得 wsRecCnt = wS.Cells(Rows.Count, 1).End(xlUp).Row - 1 ' シート"CSVインポート" にコピーしたデータ数= 1列目の最終行番号から表頭部分1行を除く。
Dim uketsukeID As String, uketsukeName As String '受付IDの値を代入するための変数 uketsukeID = wS.Cells(2, 3).Value uketsukeName = wS.Cells(2, 4).Value
Application.StatusBar = "?ECSVインポートシートのデータ検証"
If wS.Cells(1, 1) <> "管理番号" Then ' csvファイルの1列目の列名称は、"管理番号" で不変と考え、これと異なる値のファイルを選択してしまった場合は、処理対象外とする。
MsgBox "選択されたファイル:[ " & FileName & " ]は" & vbNewLine & _ "受付ファイルではありません。処理を中断します。", vbCritical + vbOKOnly Application.ScreenUpdating = True Sheets("受付一覧").Select Exit Sub Else If MsgBox("以下のファイルを受付一覧にインポートします。よろしいですか??" & vbNewLine & _ " [ファイル名] :" & FileName & vbNewLine & _ " [ID] :" & uketsukeID & vbNewLine & _ " [名称] :" & uketsukeName & vbNewLine & _ " [件数] :" & wsRecCnt & vbNewLine _ , vbInformation + vbYesNo) = vbYes Then With Sheets("CSVログ") 'シート「CSVログ"」にログ情報を書き出し .Cells(ImportHistrylastRow + 1, 1) = Cells(ImportHistrylastRow + 1, 1).Row - 1 .Cells(ImportHistrylastRow + 1, 2) = FileName .Cells(ImportHistrylastRow + 1, 3) = Now .Cells(ImportHistrylastRow + 1, 4) = wsRecCnt .Cells(ImportHistrylastRow + 1, 5) = uketsukeID .Cells(ImportHistrylastRow + 1, 6) = Left(uketsukeName, 4) .Cells(ImportHistrylastRow + 1, 7) = "OK" End With Else Exit Sub End If End If
Dim hanteisheet As Worksheet '判定用シートの定義
Application.StatusBar = "?Fcsvのコンバージョン処理"
Set hanteisheet = Worksheets("指定セル") 'シート名:「指定セル」 参照 hanteisheet.Select
Dim uketsukeCnt As Integer '定義済みの手続数 uketsukeCnt = Cells(Rows.Count, 2).End(xlUp).Row - 2 ' シート"指定セル" 標準フォーマットの項目数= 1列目の最終行番号から表頭部分2行を除く。
Dim tgt As Integer 'コピー対象となる受付番号を代入するための変数 For i = 1 To uketsukeCnt If Val(Cells(i + 2, 1)) = Val(uketsukeID) Then: tgt = i Next
Dim colCnt As Long colCnt = Sheets("受付一覧").Cells(1, Columns.Count).End(xlToLeft).Column
Dim wCol(1000) As Long For i = 1 To colCnt Application.StatusBar = "?G変換中" & i & "/" & colCnt If hanteisheet.Cells(2, i + 2) <> 0 Then wCol(hanteisheet.Cells(2, i + 2)) = hanteisheet.Cells(tgt + 2, i + 2) Else End If Next
Dim uketsuke As Worksheet Set uketsuke = Worksheets("受付一覧") '受付一覧シートの定義
Dim z As Long z = uketsuke.Cells(Rows.Count, 1).End(xlUp).Row '受付一覧シートの最終行を取得 On Error Resume Next uketsuke.Select Dim wData(1000, 1000) As String For i = 1 To wsRecCnt wData(i, 1) = Cells(z + i, 1).Row - 1 '管理番号 For A = 2 To colCnt Application.StatusBar = "?H転記中" & A & "/" & colCnt
If wCol(A) <> 0 Then: wData(i, A) = wS.Cells(i + 1, wCol(A)) wData(i, 5) = DateValue(wS.Cells(i + 1, 12) & wS.Cells(i + 1, 13) & "年" & wS.Cells(i + 1, 14) & "月" & wS.Cells(i + 1, 15) & "日") wData(i, 26) = Format(Date, "ge.m.d(aaa)") Select Case Cells(z + i, 20) Case "成績の送付先住所": wData(i, 29) = "実家" Case "証明書の住所": wData(i, 29) = "現住所" Case "" If Cells(z + i, 14) = "" Or Cells(z + i, 14) = "同上" Then wData(i, 29) = "実家" Else wData(i, 29) = "現住所" End If Dim textA As String Dim textB As String End Select wData(i, 30) = 1 wData(i, 31) = tgt Next
Next
Dim arr As Variant '100x100の掛け算表を格納する変数 ’★
arr = Range(Cells(z + 1, 1), Cells(z + wsRecCnt, colCnt)) 'Setをつけずに範囲を変数に入れる ’★
For i = 1 To wsRecCnt For j = 1 To colCnt arr(i, j) = wData(i, j) '★ Next j Next i
'配列の値ををシートに戻す。範囲を配列にした式の左右を逆にしただけ Range(Cells(z + 1, 1), Cells(z + wsRecCnt, colCnt)) = arr
Range("A1").Select
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
(たけし) 2022/12/05(月) 15:55:05
>コードの位置をかえればいいのでしょうか? >別の場所に移すとコピーされないのですが、コード自体間違ってますか?
使用前が現状のコードの結果だとすれば、 現状のコードで使用前の結果まで処理し、 新たに、使用後の結果となるようにコードを作成するのは、どうですか? といった意味です。
(tkit) 2022/12/05(月) 16:24:07
m(__)m Option Explicit Sub main() totemotaihen '←ご提示の既存、プロシジャー newproc '←tkitさん、ご提案の新規変換プロシジャー End Sub みたいな感じで、良いのではないでせうか 複数シートに跨り、厳しい管理下にある様ですし、取込自体は クエリテーブルで一括取込、されておられるようなので、いずれに 致しましても、シート名 CSVインポート の情報を再加工して、別途、シートへ、転記されるのが簡単で良いかと 存じます。。。←と、思います。(#^^#)v でわでわ m(__)m
(隠居Z) 2022/12/05(月) 19:14:57
|[A]|[B] [1] | | [2] | 1| [3] | 2| [4] | 3| [5] | 4| [6] | 5| [7] | 6| [8] | 7| [9] | 8| [10]| 9| [11]| 10| [12]| | [13]| | は、↑みたいな感じでした、 >>シート名(受付一覧) >>使用前
は
>>シート名 CSVインポート
のお間違いでは。。。^^;
迷っています。(#^^#)
m(__)m
(隠居Z) 2022/12/05(月) 19:45:09
Option Explicit Private Sub zddcsvmk() Rnd -7 Dim v(), i&, j&, iMax&, buf, ktx(), stx(), md() ReDim md(1 To 40) ReDim v(1 To 40) iMax = 10 ktx = Array("教科書", "") stx = Array("参考書", "") md(1) = "管理番号" For i = 2 To 40 md(i) = "F" & i Next Open ThisWorkbook.Path & "\" & "\student01.csv" For Output As #1 Print #1, Join(md, ",") i = 1 Do v(1) = 10000 + i v(2) = Chr(Int((90 - 65 + 1) * Rnd + 65)) & _ Chr(Int((90 - 65 + 1) * Rnd + 65)) & _ Chr(Int((90 - 65 + 1) * Rnd + 65)) & "高校" v(3) = "苗字" & i & "名前" & 1 v(4) = "実家住所" v(5) = "現住所" For j = 6 To 38 v(j) = "Dummy" & Chr(Int((90 - 65 + 1) * Rnd + 65)) Next v(39) = ktx(Int((1 - 0 + 1) * Rnd + 0)) If v(39) = "" Then v(40) = stx(0) Else v(40) = stx(Int((1 - 0 + 1) * Rnd + 0)) End If buf = Join(v, ",") Print #1, buf i = i + 1 If i > iMax Then Exit Do If i Mod 32 = 0 Then DoEvents Loop Close #1 End Sub 恐怖の憶測と推測のダミーデータ[10件です。] 相違点が御座いましたら、ご指摘を。m(__)m (隠居Z) 2022/12/05(月) 19:51:15
■1
「colCnt」は、いつどこで取得しているのですか?
「wS」は、いつどこで取得しているのですか?
■2
Set uketsuke = Worksheets("受付一覧") uketsuke.Select wData(i, 1) = Cells(z + i, 1).Row - 1 '管理番号
↑のようにいちいち選択(アクティブに)しなくても↓のようにすれば十分では?
wData(i, 1) = Worksheets("受付一覧").Cells(z + i, 1).Row - 1 '管理番号
また、↓のようにwithステートメントの利用も有効だと思います。
With Worksheets("受付一覧") z = .Cells(.Rows.Count, 1).End(xlUp).Row wData(i, 1) = .Cells(z + i, 1).Row - 1
■3
↓についてマルチステートメントで記述する狙いはなんですか?
If wCol(A) <> 0 Then: wData(i, A) = wS.Cells(i + 1, wCol(A))
■4
好みの問題でしょうが↓の方もSelect Caseの出番では?
If Cells(z + i, 14) = "" Or Cells(z + i, 14) = "同上" Then
■5
全体的な話としては、エクセルに取り込んだなら、無理に配列上で処理しなくても、シート上で抽出なり加工したりしたっていいんじゃないかなと思いました。
(もこな2) 2022/12/05(月) 20:27:04
何もご返事が頂けない様で、もうご覧になっていないかもですが 勉強のために、作ってみました、詳細のご解説がいただければ、 wData → arr へ移行の際に、同じようなロジックを突っ込めばいいかな、とは思いましたが ま、なぁ〜んとなくは、解読できたつもりですが、そんな気がするだけで 勘違いかも、下記も推測の領域を出ませんので、いい加減なコードかもしれません 全て処理が終わってから、出来上がったものを別途、処理するパターンです。 m(__)m Option Explicit Sub newProc() If Worksheets("受付一覧").Cells(2, 1) = "" Then Exit Sub Dim i As Long Dim j As Long Dim n As Long Dim v() As Variant Dim w() As Variant Dim aAry() As Variant Dim idx() As Variant With Worksheets("受付一覧") v = .Cells(1).CurrentRegion.Value .Copy after:=Worksheets(Worksheets.Count) End With For i = 2 To UBound(v, 1) ReDim w(1 To UBound(v, 2)) For j = 1 To UBound(v, 2) w(j) = v(i, j) Next ReDim Preserve idx(n) idx(n) = w n = n + 1 If v(i, 39) = "教科書" And v(i, 40) = "参考書" Then ReDim Preserve idx(n) idx(n) = w n = n + 1 End If Next ReDim aAry(1 To UBound(idx) + 1, 1 To UBound(v, 2)) For i = 0 To UBound(idx) For j = 1 To UBound(idx(i)) aAry(i + 1, j) = idx(i)(j) Next Next With ActiveSheet .UsedRange.Clear .Cells(1).Resize(, UBound(v, 2)) = Application.Index(v, 1, 0) .Cells(2, 1).Resize(UBound(aAry, 1), UBound(aAry, 2)) = aAry End With End Sub (隠居Z) 2022/12/06(火) 19:25:03
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.