Excelのセルをコピー

質問

VBから呼び出したExcelファイルを
一行ずつセルごとに一つずつ読んでいき
特定のセルに0～9の数字が入っていたら
そこまでの５セル分をコピーして
新しいExcelに一行目から貼り付けていきたいのですが、
セルの扱い方がよくわかりません。
どうすればいいのか教えてください。

回答No.4

pen_pen_pen · ベストアンサー

中途半端な回答してしまって申し訳ありません。
★のところは、その下の「65」の代わりに入れたかったのです。
見やすく変数にでも入れると良いでしょう。

>For i = 1 To 65
はやめて、

'一続きのセル範囲の行数を取得
rowNum = xlNameSheet.Range("A1").CurrentRegion.Rows.Count '★

For i = 1 To rowNum
・・・
にします。

それから、
>これが65行目まで行くと6列目にきてまた2行目、3行目・・・
>と続いていきます。
>またご指摘のとおり、名簿により60行までだったり
>65行までだったりします。
>そして名簿によって、15列(3人分)だったり20列(4人分)だったりします。

との事なので、列方向に何人分かも必要ですね。
'一続きのセル範囲の列数を取得（5、10、15、20のどれかになるハズ）
colNum = xlNameSheet.Range("A1").CurrentRegion.Columns.Count

'1行にある人数（1人～4人）列数を5で割れば人数。
ninzu = colNum \ 5
で取れます。
今ある65行で回すループの更に上にninzuで回すループが必要になります。

お礼

お手数おかけしました。
なんとか正常に動くようになりました。
本当にどうもありがとうございました。

補足

毎回ありがとうございます。本当に助かっています。
>今ある65行で回すループの更に上にninzuで回すループが必要になります。
ということですが、何度考えてやってみても思い通りに表示できません。
何点か教えていただきたいです。
修正した部分だけ掲載します。

cnt = 0
rowNum=xlNameSheet.Range("A1").CurrentRegion.Rows.Count
For i = 1 To rowNum
shusseki = xlNameSheet.Cells(i, 5).Value　☆
If IsNumeric(shusseki) Then
stno = xlNameSheet.Cells(i, 1)
stno = Form10.Text1 & stno　’文字列結合
xlNewSheet.Cells(i, 1) = stno　★
cnt = cnt + 1
colNum=xlNameSheet.Range("A1").CurrentRegion.Columns.Count
ninzu = colNum \ 5
For j = 1 To ninzu
xlNewSheet.Cells(cnt, j).Value = xlNameSheet.Cells(i, j).Value

これで実行すると、新しいExcelシートが一応は表示されるのですが、
結合した文字列のセルが１列目で飛び飛びになってしまいます（間隔があいてしまうのです）。
１行目、２行目と上から順に表示させたいので、
★の行のｉを変更したいのですが考え付きません。
また☆の部分では(i, 5)となっているので１列目から５列目までの学生の分しか表示されず（最大で６５人分）、
６列目から１０列目までの学生、または１１列目から１５列目までの学生の出席はセルで確認できず、表示されません。
どのようにすれば５列目、１０列目、１５列目といった
出席が確認できるセルのデータを取得できるでしょうか。
何度も申し訳ありませんが、よろしくお願いします。

回答No.3

pen_pen_pen

追いかけて来ました。
ファイル名を取るのはできたようですね。おめでとうございます。

ファイル名取得の時にも言いましたが、Open～ではEXCELファイルの中身は読めません。
今回の処理では、
Open xlFileName For Input As #1
Line Input #1, a
Close #1
というファイルの読み込み方は忘れて下さい。

なぜ何も起こらなかったかというと、
>n = 1
>While n = 65
です。
>n = 1
なのに、その後のループが
>While n = 65
つまり、n が 65の間。nは1ですから、ループには入らず、終わったのです。
でもこの場合はWhileではなくForを使ったループが良いと思います。

以下、未確認なソース。
雰囲気はこんな感じで出来そうです。
たぶんエラーは起きるので、修正して下さい。

------------------------------------------
Dim shusseki As String
Dim cnt As Integer
Dim i As Integer
Dim j As Integer
Dim xlApp As EXCEL.Application
Dim xlBook As EXCEL.WorkBook
Dim xlNameSheet As EXCEL.WorkSheet
Dim xlNewSheet As EXCEL.WorkSheet

'EXCEL起動
set xlApp = CreateObject("EXCEL.Application")

'元になる名簿EXCELファイルを開く
set xlBook = xlApp.WorkBooks.Open(xlFileName)

'シートを取得
'シートが1つしか無いなら。名前が決まってるなら、
'Set xlNameSheet = xlBook.Sheets.Item("シートの名前")
Set xlNameSheet = xlBook.Sheets.Item(1)

'新しいシートを追加
Set xlNewSheet = xlBook.Sheets.Add()

cnt = 0
'↓ホントは実際に何行あるか調べて変数でやりたい。必ずしも65人分あるとは限らないなら。
'xlNameSheet.Range("A1").CurrentRegion.Rows.Countでいけそうな・・？
For i = 1 to 65
'出席列の中身を取得
shusseki = xlNameSheet.Cells(i, 5).Value
if IsNumeric(shusseki) Then
cnt = cnt + 1
For j = 1 To 5
xlNewSheet.Cells(cnt, j).Value = xlNameSheet.Cells(i, j).Value
Next j
End If
Next i

xlBook.Save
xlBook.Close
xlApp.Quit

Set xlNameSheet = Nothing
Set xlNewSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing

------------------------------------------

さて、疑問ですが、
5列（番号、姓、名前、フリガナ、出席）しかないのに、
>最大セルは(65,20)です。
とは？？(65, 5)ではないのですか？

疑問2
最後にできあがるファイルはいくつですか？
A.読み込んだファイルに、1つシートを追加して上書き保存すれば良い？
B.読み込んだファイルとは別にシートが1つの新しいEXCELファイルを作り、読み込みファイルは何もしない？
C.1人分ごとに1つのファイルを作る？
上の適当なソースでは、Aとして解釈してます。

補足

詳しい回答ありがとうございます。

>5列（番号、姓、名前、フリガナ、出席）しかないのに、
>>最大セルは(65,20)です。
>とは？？(65, 5)ではないのですか？

名簿は下記のような感じになっています。｜がセルごとの区切り記号です。
001｜新井｜花子｜アライハナコ｜１｜
一人分がこの５列です。
これが65行目まで行くと6列目にきてまた2行目、3行目・・・
と続いていきます。
またご指摘のとおり、名簿により60行までだったり
65行までだったりします。
そして名簿によって、15列(3人分)だったり20列(4人分)だったりします。

>最後にできあがるファイルはいくつですか？
についてですが
B.読み込んだファイルとは別にシートが1つの新しいEXCELファイルを作り、読み込みファイルは何もしない
ものとして作成しています。

pen_pen_penさんのソースをもとに修正しました。

Set xlApp = CreateObject("Excel.Application")
xlFileName = strFileName
Set xlBook = xlApp.Workbooks.Open(xlFileName)
Set NeoSheet = xlApp.Workbooks.Add
Set xlNameSheet = xlBook.Sheets.Item(1)
cnt = 0
xlNameSheet.Range("A1").CurrentRegion.Rows.Count★
For i = 1 To 65
shusseki = xlNameSheet.Cells(i, 5).Value
If IsNumeric(shusseki) Then
cnt = cnt + 1
For j = 1 To 5
xlNewSheet.Cells(cnt, j).Value = xlNameSheet.Cells(i, j).Value
Next j
End If
Next i

★の部分で「プロパティの使い方が不正」のエラーがでます。これから直してみます。

回答No.2

imogasi

プログラムをやろうと言う人が、もう少し表現を正確に表現すべきです。
「エクセルのＳｈｅｅｔ１のＡ，Ｂ，Ｃ，Ｄ列に、１行１名で、番号、姓、名前、フリガナが入っている。Ｅ列には
出席した者の行には出席回数？が入っている。
出席歴のある人だけ、Ｓｈｅｅｔ２に抜き出したい。」
などどうですか。
エクセルに入って後の部分だけご参考に。
Sub test01()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Worksheets("sheet1")
Set sh2 = Worksheets("sheet2")
d = sh1.Range("a65536").End(xlUp).Row
MsgBox d
tb = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9)
j = 1
For i = 1 To d
For k = 0 To 9
If sh1.Cells(i, "E") = tb(k) Then
sh2.Cells(j, "A") = sh1.Cells(i, "A")
sh2.Cells(j, "B") = sh1.Cells(i, "B")
sh2.Cells(j, "C") = sh1.Cells(i, "C")
sh2.Cells(j, "D") = sh1.Cells(i, "D")
sh2.Cells(j, "E") = sh1.Cells(i, "E")
j = j + 1
Exit For
End If
Next k
Next i
End Sub
セルが空白だと０と等しくなるようなので、空白を拾わないように、文字を入れるとか、９９９など入れるようにすべきかも知れません。
＞セル(1,0)
紛らわしい。Ａ１セルは（１，１）で表現が良いでしょう。
＞新しいExcelに
新しいエクセルのシートに
＞そこまでの５セル分
なぜ突然５セルなの（補足で判るが）
＞If Cells(n, 4 + i) = 0 <= 9 Then
？？？
＞Set xlApp = CreateObject("Excel.Application")
Ｃｅｌｌｓを使えるのはエクセルＶＢＡの世界。したがってCreateObjectはもっと早く出るべき。
＞Cells(n, i)(n, i + 1)(n, i + 2)(n, i + 3).Copy
むちゃくちゃ。エクセルＶＢＡのＲａｎｇｅの表現法を
勉強すべし。

回答No.1

freednia

質問文がよくわかりません。
特定の列に数字が入っている行をコピペするんですか？
そこは数字が入っていない場合は空欄ですか？
そこまでの５セルというのはその行も含めて上5行ですか？
数字を見つけるたびに新規ファイルを開いて貼り付けるんですか？
そうすると数字がある行の数だけファイルが出来ますが。

ちなみに質問者様の考えたコードを不完全でも掲載してくださればアドバイスしやすいです。

補足

説明不足で申し訳ありません。
まずVBから既存のExcelファイルを呼び出します。
そのExcelファイルとは名簿ファイルで、セル(1,0)から(1,4)までの５セル分に一人分の情報が入っています。
セル(1,0)から番号、(1,1)名字、(1,2)名前、(1,3)フリガナ、(1,4)出席となっています。
最大セルは(65,20)です。
(1,4)の出席のセルには、出席者のみに数字が入っていて全員入っているわけではありません。
この(1,4)の出席セルに数字が入っていたら、そこまでの
(1,0)番号、(1,1)名字、(1,2)名前、(1,3)フリガナ、(1,4)出席を（一人分の情報）をコピーし、
別の新しいExcelシートに一行ずつ貼り付けていき、
最後に出来あがったものを表示させたいのです。
下記を実行するとエラー表示はないのですが
何の反応もありません・・・

Private Sub Command1_Click()
xlFileName = strFileName
Debug.Print strFileName, xlFileName
Open xlFileName For Input As #1
n = 1
While n = 65
Line Input #1, a

i = 0
Do Until i = 20
If Cells(n, 4 + i) = 0 <= 9 Then
Cells(n, i)(n, i + 1)(n, i + 2)(n, i + 3).Copy
Set xlApp = CreateObject("Excel.Application")
ActiveSheet.Paste
i = i + 5
End If
n = n + 1
Loop
Wend
Close #1
End Sub
長々とすみません、よろしくお願いします。