Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
1993 / 13665 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【70724】データベースからの転記について うろ 11/12/20(火) 11:42 質問[未読]
【70725】Re:データベースからの転記について Hirofumi 11/12/20(火) 12:53 発言[未読]
【70726】Re:データベースからの転記について うろ 11/12/20(火) 13:42 質問[未読]
【70731】Re:データベースからの転記について Hirofumi 11/12/20(火) 18:59 発言[未読]
【70732】Re:データベースからの転記について Hirofumi 11/12/20(火) 19:49 発言[未読]
【70733】Re:データベースからの転記について Hirofumi 11/12/20(火) 20:45 発言[未読]
【70735】Re:データベースからの転記について うろ 11/12/21(水) 13:47 お礼[未読]
【70724】データベースからの転記について
質問  うろ  - 11/12/20(火) 11:42 -
引用なし
パスワード
   実は、知恵袋で同様の質問をさせていただいたのですが、
文字数の制限があったり、書き直しが出来なかったりで、
使いにくかったので、再度こちらに質問させて頂きます。

目的はデータベースから、発注書フォーマットへの転記です。
知恵袋で教えていただいたのを修正したりしながら、
試行錯誤しているのですが、どうしてもきちんと転記されないです。

コードは以下の通りです。

Sub Macro()
Dim mySh1, mySh2, i, myRow, actRow
If TypeName(Selection) <> "Range" Then
MsgBox "A列のセルを選択して下さい(終了)"
Exit Sub
End If
actRow = ActiveCell.Row
If Sheets(Sheets.Count).Name <> "New" Then
Sheets("発注書").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = Format(Now, "yymmdd_hhmmss")
End If
Set mySh1 = Sheets("一覧")
Set mySh2 = ActiveSheet
For i = 15 To 22
If mySh2.Range("A" & i) = "" Then
myRow = i
Exit For
End If
Next i
If myRow = 0 Then
MsgBox "空欄がありません！"
End If
Exit Sub
With mySh2
.Range("F" & myRow).Value = mySh1.Range("A" & actRow).Value
.Range("A" & myRow).Value = mySh1.Range("B" & actRow).Value
.Range("G" & myRow).Value = mySh1.Range("C" & actRow).Value
.Range("H" & myRow).Value = mySh1.Range("D" & actRow).Value
.Range("G11").Value = mySh1.Range("E" & actRow).Value
.Range("A3").Value = mySh1.Range("F" & actRow).Value
.Range("A1").Value = mySh1.Range("G" & actRow).Value
.Range("I2").Value = mySh1.Range("H" & actRow).Value
.Range("I12").Value = mySh1.Range("I" & actRow).Value
.Range("I" & myRow).Value = mySh1.Range("J" & actRow).Value
.Range("B23").Value = mySh1.Range("K" & actRow).Value
.Range("I5").Value = mySh1.Range("L" & actRow).Value
End With
mySh2.Select
Set mySh1 = Nothing
Set mySh2 = Nothing
End Sub

自分では、
For i = 15 To 22
If mySh2.Range("A" & i) = "" Then
myRow = i
Exit For
の部分が問題ではないかと思っているのですが、
色々変えてみても上手くいかないので、行き詰ってます。

何卒、ご指南のほどよろしくお願い致します。
【70725】Re:データベースからの転記について
発言  Hirofumi  - 11/12/20(火) 12:53 -
引用なし
パスワード
   Sub Macro()
　　
　　Dim mySh1, mySh2, i, myRow, actRow
　　
　　If TypeName(Selection) <> "Range" Then
　　　　MsgBox "A列のセルを選択して下さい(終了)"
　　　　Exit Sub
　　End If
　　
　　actRow = ActiveCell.Row
　　If Sheets(Sheets.Count).Name <> "New" Then
　　　　Sheets("発注書").Copy After:=Sheets(Sheets.Count)
　　　　ActiveSheet.Name = Format(Now, "yymmdd_hhmmss")
　　End If
　　
　　Set mySh1 = Sheets("一覧")
　　Set mySh2 = ActiveSheet
　　
　　For i = 15 To 22
　　　　If mySh2.Range("A" & i) = "" Then
　　　　　　myRow = i
　　　　　　Exit For
　　　　End If
　　Next i
　　
　　If myRow = 0 Then
　　　　MsgBox "空欄がありません！"
　　End If
　　
　　Exit Sub '此処でSubから無条件で抜けているので、以降のコードは実行されないよ？？
　　
　　With mySh2
　　　　.Range("F" & myRow).Value = mySh1.Range("A" & actRow).Value
　　　　.Range("A" & myRow).Value = mySh1.Range("B" & actRow).Value
　　　　.Range("G" & myRow).Value = mySh1.Range("C" & actRow).Value
　　　　.Range("H" & myRow).Value = mySh1.Range("D" & actRow).Value
　　　　.Range("G11").Value = mySh1.Range("E" & actRow).Value
　　　　.Range("A3").Value = mySh1.Range("F" & actRow).Value
　　　　.Range("A1").Value = mySh1.Range("G" & actRow).Value
　　　　.Range("I2").Value = mySh1.Range("H" & actRow).Value
　　　　.Range("I12").Value = mySh1.Range("I" & actRow).Value
　　　　.Range("I" & myRow).Value = mySh1.Range("J" & actRow).Value
　　　　.Range("B23").Value = mySh1.Range("K" & actRow).Value
　　　　.Range("I5").Value = mySh1.Range("L" & actRow).Value
　　End With
　　
　　mySh2.Select
　　
　　Set mySh1 = Nothing
　　Set mySh2 = Nothing
　　
End Sub
【70726】Re:データベースからの転記について
質問  うろ  - 11/12/20(火) 13:42 -
引用なし
パスワード
   !!!!
返信有難うございます。
ご指摘の通りです。
そりゃそうですよね。。。

Exit Subを外したら、転記されるようにはなりました。

ただ、思い描いた通りの動作では無かったです。
本当は、データベースで選択した複数の数値を
発注書フォーマットにまとめて転記したかったのですが、
転記されない。。。

動かして確認して見ましたが、セル位置の間違いでは無いみたいです。
複数の値をデータベースで選択しても、一番最初の値しか転記されません。
変数の設定の仕方が間違っているのか・・・、元々の構文が間違っているのか・・。

自分でも調べて見ますが、もしご助言等ありましたら
よろしくお願い致します。
【70731】Re:データベースからの転記について
発言  Hirofumi  - 11/12/20(火) 18:59 -
引用なし
パスワード
   ▼うろ さん：
>!!!!
>返信有難うございます。
>ご指摘の通りです。
>そりゃそうですよね。。。
>
>Exit Subを外したら、転記されるようにはなりました。
>
>ただ、思い描いた通りの動作では無かったです。
>本当は、データベースで選択した複数の数値を
>発注書フォーマットにまとめて転記したかったのですが、
>転記されない。。。
>
>動かして確認して見ましたが、セル位置の間違いでは無いみたいです。
>複数の値をデータベースで選択しても、一番最初の値しか転記されません。
>変数の設定の仕方が間違っているのか・・・、元々の構文が間違っているのか・・。
>
>自分でも調べて見ますが、もしご助言等ありましたら
>よろしくお願い致します。

ループしていないから、1回しか転記しないのでは？
【70732】Re:データベースからの転記について
発言  Hirofumi  - 11/12/20(火) 19:49 -
引用なし
パスワード
   データが無くてテストしていないから自信が無いけど？
こんなかな？

Sub Macro()

　　'転記先頭行位置
　　Const clngPostT As Long = 15
　　'転記最終行位置
　　Const clngPostE As Long = 22
　　
　　Dim i As Long
'　　Dim mySh1 As Worksheet
　　Dim mySh2 As Worksheet
　　Dim myRow As Long
'　　Dim actRow As Long
　　
　　Dim j As Long
　　Dim rngMark As Range
　　Dim strPrompt As String

　　If TypeName(Selection) <> "Range" Then
　　　　strPrompt = "セル範囲を選択して下さい"
　　　　GoTo Wayout
　　End If

　　Set rngMark = Intersect(Selection, Columns("A"))
　　If rngMark Is Nothing Then
　　　　strPrompt = "A列のセルを選択して下さい(終了)"
　　　　GoTo Wayout
　　End If
　　
'　　actRow = ActiveCell.Row
　　If Sheets(Sheets.Count).Name <> "New" Then
　　　　Sheets("発注書").Copy After:=Sheets(Sheets.Count)
　　　　ActiveSheet.Name = Format(Now, "yymmdd_hhmmss")
　　End If

'　　Set mySh1 = Sheets("一覧")
　　Set mySh2 = ActiveSheet

'　　For i = 15 To 22
　　For i = clngPostT To clngPostE
　　　　If mySh2.Range("A" & i) = "" Then
'　　　　　　myRow = i
　　　　　　Exit For
　　　　End If
　　Next i
'　　If myRow = 0 Then
　　If i > clngPostE Then
　　　　strPrompt = "空欄がありません！"
　　　　GoTo Wayout
　　End If

'　　Exit Sub '此処でSubから無条件で抜けているので、以降のコードは実行されないよ？？

　　For i = i To clngPostE
　　　　j = j + 1
　　　　With mySh2
　　　　　　.Range("F" & i).Value = rngMark.Cells(j, "A").Value
　　　　　　.Range("A" & i).Value = rngMark.Cells(j, "B").Value
　　　　　　.Range("G" & i).Value = rngMark.Cells(j, "C").Value
　　　　　　.Range("H" & i).Value = rngMark.Cells(j, "D").Value
　　　　　　.Range("I" & i).Value = rngMark.Cells(j, "J").Value
　　　　End With
　　Next i
　　　　
　　With mySh2
　　　　.Range("G11").Value = rngMark.Cells(1, "E").Value
　　　　.Range("A3").Value = rngMark.Cells(1, "F").Value
　　　　.Range("A1").Value = rngMark.Cells(1, "G").Value
　　　　.Range("I2").Value = rngMark.Cells(1, "H").Value
　　　　.Range("I12").Value = rngMark.Cells(1, "I").Value
　　　　.Range("B23").Value = rngMark.Cells(1, "K").Value
　　　　.Range("I5").Value = rngMark.Cells(1, "L").Value
　　End With

　　mySh2.Select

Wayout:

'　　Set mySh1 = Nothing
　　Set mySh2 = Nothing
　　Set rngMark = Nothing
　　
　　MsgBox strPrompt, vbInformation
　　
End Sub
【70733】Re:データベースからの転記について
発言  Hirofumi  - 11/12/20(火) 20:45 -
引用なし
パスワード
   ゴメン勘違いしました
こんなので？

Sub Macro()

　　'転記先頭行位置
　　Const clngPostT As Long = 15
　　'転記最終行位置
　　Const clngPostE As Long = 22
　　
　　Dim i As Long
'　　Dim mySh1 As Worksheet
　　Dim mySh2 As Worksheet
　　Dim myRow As Long
'　　Dim actRow As Long
　　
　　Dim j As Long
　　Dim rngMark As Range
　　Dim rngElement As Range
　　Dim strPrompt As String

　　If TypeName(Selection) <> "Range" Then
　　　　strPrompt = "セル範囲を選択して下さい"
　　　　GoTo Wayout
　　End If

　　Set rngMark = Intersect(Selection, Columns("A"))
　　If rngMark Is Nothing Then
　　　　strPrompt = "A列のセルを選択して下さい(終了)"
　　　　GoTo Wayout
　　End If
　　
'　　actRow = ActiveCell.Row
　　If Sheets(Sheets.Count).Name <> "New" Then
　　　　Sheets("発注書").Copy After:=Sheets(Sheets.Count)
　　　　ActiveSheet.Name = Format(Now, "yymmdd_hhmmss")
　　End If

'　　Set mySh1 = Sheets("一覧")
　　Set mySh2 = ActiveSheet

'　　For i = 15 To 22
　　For i = clngPostT To clngPostE
　　　　If mySh2.Range("A" & i) = "" Then
'　　　　　　myRow = i
　　　　　　Exit For
　　　　End If
　　Next i
'　　If myRow = 0 Then
　　If i > clngPostE Then
　　　　strPrompt = "空欄がありません！"
　　　　GoTo Wayout
　　End If

'　　Exit Sub '此処でSubから無条件で抜けているので、以降のコードは実行されないよ？？

　　For Each rngElement In rngMark
　　　　With mySh2
　　　　　　.Range("F" & i).Value = rngElement.Value
　　　　　　.Range("A" & i).Value = rngElement.Offset(, 1).Value
　　　　　　.Range("G" & i).Value = rngElement.Offset(, 2).Value
　　　　　　.Range("H" & i).Value = rngElement.Offset(, 3).Value
　　　　　　.Range("I" & i).Value = rngElement.Offset(, 9).Value
　　　　End With
　　　　i = i + 1
　　　　If i > clngPostE Then
　　　　　　Exit For
　　　　End If
　　Next rngElement
　　
　　With mySh2
　　　　.Range("G11").Value = rngMark.Cells(1, "E").Value
　　　　.Range("A3").Value = rngMark.Cells(1, "F").Value
　　　　.Range("A1").Value = rngMark.Cells(1, "G").Value
　　　　.Range("I2").Value = rngMark.Cells(1, "H").Value
　　　　.Range("I12").Value = rngMark.Cells(1, "I").Value
　　　　.Range("B23").Value = rngMark.Cells(1, "K").Value
　　　　.Range("I5").Value = rngMark.Cells(1, "L").Value
　　End With

　　mySh2.Select

Wayout:

'　　Set mySh1 = Nothing
　　Set mySh2 = Nothing
　　Set rngMark = Nothing
　　
　　MsgBox strPrompt, vbInformation
　　
End Sub
【70735】Re:データベースからの転記について
お礼  うろ  - 11/12/21(水) 13:47 -
引用なし
パスワード
   返信有難うございます。

知らない構文が一杯で、私の頭もいっぱいいっぱいな感じでしたが、
目的の動作をしてくれました。

真に有難うございました。

教えて頂いたマクロを理解するのは、もう少し時間がかかりそうです。
構文を組み合わせていくのはまだまだ難しいですが、
ちゃんと使えるようになりたいと思います。

本当に有難うございました。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
1993 / 13665 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free