[[20221205133457]] 『インポートしたCVSデータを転記するときにある条戟x(たけし) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) |

| 全文検索 | 過去ログ ]

 

『インポートした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 >


私にはさっぱり解りませんが、これだけ書けて自分で工夫とかできないもんなんですかね?
プログラムって、そういうもんなんですか?
(ビート) 2022/12/05(月) 14:11:41

基盤は他の方が組んでいて、私は追加でコピーするシステムを組み込みたいのですが、基盤を組んだ人はいなくなってしまったので聞けないのです。
私自身は基本程度の知識しかなく、色々調べて試しましたができなかったので、教えていただきたいです。
(たけし) 2022/12/05(月) 14:40:04

こんにちわ〜^^

>>両方入っているとき同じものを下にコピーして2列にしたい。
どぉなればよいのでしょうか。^^;←解らないのは私だけ?
切り出しのコードだけ拝見させて戴いても、なぁ〜んとなく
解りずらいですよね。可能でしたら、部分的で、中身は偽情報
で構わないので解りやす~く
使用前
使用後
みたいな感じで、エクセルのシート名、セル番地が解るように
エクセルの表形式で、元情報と、ご希望の、結果図をお示し賜れば
お手伝い出来ることが有るかもしれません。。。←多分。怪しいかも( ̄▽ ̄)
ちょっと、コードおっかけてみますか。(#^^#)///〜?
でわでわ
m(__)m
(隠居Z) 2022/12/05(月) 14:42:32

wCol(A)
って
何ですか。配列かな〜〜〜それとも、パラメータつきのファンクションプロシジャ
かな??;
いっそ、ぜ〜〜〜〜んぶ、ここに、貼り付けてみてぇ〜コード
もし、差支えなければ&もし、宜しければ。。。の、お話ですが。^^;
もちろん、お気に召さなければ、無視して戴いて結構です。
m(__)m
(隠居Z) 2022/12/05(月) 15:09:47

コードだけだと解りにくかったですよね、申し訳ないです。
シート名(受付一覧)
使用前
A1, A2  , A3 , A4 , A5 ,A6(i,39),A7(i,40)
1,三角高校,山田太郎,実家住所,現住所,教科書,参考書
2,三角高校,田中花子,実家住所,現住所,教科書,空欄
3,四角高校,佐藤 一,実家住所,現住所,空欄 ,参考書
使用後
1,三角高校,山田太郎,実家住所,現住所,教科書,参考書
1,三角高校,山田太郎,実家住所,現住所,教科書,参考書
2,三角高校,田中花子,実家住所,現住所,教科書,空欄
3,四角高校,佐藤 一,実家住所,現住所,空欄 ,参考書

上記のようにインポートしたデータを受付一覧シートに転記する際、使用前には順番通りに転記され、使用後にまったく同じものをコピーしたいです。
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


>wDataを張り付けているコードがあるはずなので、その後に、データを判定して挿入やら貼付けやらを行う、という手があります。
というのはコードの位置をかえればいいのでしょうか?別の場所に移すとコピーされないのですが、コード自体間違ってますか?
(たけし) 2022/12/05(月) 16:09:04

 >コードの位置をかえればいいのでしょうか?
 >別の場所に移すとコピーされないのですが、コード自体間違ってますか?

 使用前が現状のコードの結果だとすれば、
 現状のコードで使用前の結果まで処理し、
 新たに、使用後の結果となるようにコードを作成するのは、どうですか?
 といった意味です。

(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


ご提示のコードを実行すれば[件数10件のダミーCSV使用]
シート名 受付一覧
     |[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


おや!
済みません、シート名 CSVインポート は何でも
取り込んでしまうようですね。今一度よく、拝見いたします。
済みませんでした。m(__)m
(隠居Z) 2022/12/05(月) 20:44:50

よろしければ、指定シートの
指定方法を教えて戴けますでせうか。←後学のためです。
[興味本位ですが済みません。^^;]
(隠居Z) 2022/12/05(月) 21:27:40

 何もご返事が頂けない様で、もうご覧になっていないかもですが
勉強のために、作ってみました、詳細のご解説がいただければ、
 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.