あまり変なものは使っていないので(基本的なものばかり)バージョンによるエラーは起こりづらいだろうなと思っています。
むしろシートやセルの名前が違うとか(完全一致しないと半角全角スペースの有無の違いでもだめ)、データ型が違うとかのようなエラーは起こっているかもしれません。
シート名の箇所をわかりやすく(というかそのまま使えるように)して、お隣の列に移るようにしてみました。
ちなみに全くスピードは追求しておりません。
Sub 入庫()
Dim l As Long 'コースの列場所
Dim d As Long '段積み数
Dim s As Long 'シートを確定するための変数
Dim k As Long, c As Long, j As Long, t As Long, n As Long '計算のための変数
Dim data As Variant
Dim ws As Worksheet
data = Sheets("Sheet1").Range("a1:g" & Range("a1000").End(xlUp).Row)
For j = 2 To UBound(data) 'シート1の行分だけ繰り返す
s = (Int(Val(data(j, 7) - 1) / 10) + 1) * 10
Set ws = Sheets(CStr(s - 9) & "-" & CStr(s))
’新しい約束事でのシート名。存在しないとエラーに
l = ((Val(data(j, 7)) - 1) Mod 10) * 5 + 2
Select Case data(j, 5)
Case "中"
d = 3
Case "小" 'パレット種による場合わけ
d = 5
End Select
c = data(j, 6) 'ループで書き込むたびにパレット数を減らす
k = 2 '書き始めの行位置
Do
If ws.Cells(k, l).Value = "" Then '記入があるか確認して
t = d
If c < d Then t = c 'tはコピペする行数
For n = 1 To 4
ws.Range(ws.Cells(k, l + n - 1), ws.Cells(k + t - 1, l + n -1)) = data(j, n)
Next
c = c - d '残りのパレット数
End If
If c <= 0 Then Exit Do 'パレット残数が0になったらループを抜ける
k = k + 6
if k>91 then '91行目を超えると次のコースの頭に移る
k=2
l=l+5
end if
Loop
Next
End Sub
やっぱり確認してから送らないと駄目ですね。
配列を使うものに戻しました。
前の補足でシート名が変わったようなので、対応させたものを’でコメントアウトして載せてます。
使う場合には’をとって(2行とも)使ってください。
ちなみに私のコードでもコースの列が足りなくなったからといってお隣のコースには移りません。
移ったほうが良いのですか?
Sub 入庫()
Dim l As Long 'コースの列場所
Dim d As Long '段積み数
Dim s As Long 'シートを確定するための変数
Dim k As Long, c As Long, j As Long, t As Long, n As Long '計算のための変数
Dim data As Variant
Dim ws As Worksheet
data = Sheets("Sheet1").Range("a1:g" & Range("a1000").End(xlUp).Row)
For j = 2 To UBound(data) 'シート1の行分だけ繰り返す
Set ws = Sheets("Sheet" & CStr(Int(Val(data(j, 7)) / 10) + 2)) '書き込みシートの指定
's = (Int(Val(data(j, 7) - 1) / 10) + 1) * 10
'Set ws = Sheets(CStr(s - 9) & "-" & CStr(s))
l = ((Val(data(j, 7)) - 1) Mod 10) * 5 + 2 '書き込みシート内の列の指定
Select Case data(j, 5)
Case "中"
d = 3
Case "小" 'パレット種による場合わけ
d = 5
End Select
c = data(j, 6) 'ループで書き込むたびにパレット数を減らす(減らす前のパレット数)
k = 2 '書き始めの行位置
Do
If ws.Cells(k, l).Value = "" Then '記入があるか確認して
t = d
If c < d Then t = c 'tはコピペする行数
For n = 1 To 4
ws.Range(ws.Cells(k, l + n - 1), ws.Cells(k + t - 1, l + n - 1)) = data(j, n)
Next
c = c - d '残りのパレット数
End If
If c <= 0 Then Exit Do 'パレット残数が0になったらループを抜ける
k = k + 6
Loop Until ws.Range("a10000").End(xlUp).Row < k '無限ループ回避(特に必要ない)1コース内2000列よりは少ないよね?
Next
End Sub
時系列管理を含めると多分その方法ではどうにもならない(つかえない)と思うのですが、とりあえず入庫の書き込みに関してだけ考えていきます。
sheet2から後のシートはよく分からなかったので(画像では読み取れない)
・データはB2から入る(A列とB列は見だし)
・コース・列が変わるごとに1行・1列あける。
・シート1枚に1コースから10コース、11コースから20コースと入っている と仮定する。
Sub 入庫()
Dim l As Long 'コースの列場所
Dim d As Long '段積み数
Dim k As Long, c As Long, j As Long, t As Long '計算のための変数
Dim ws As Worksheet
Dim ws1 As Worksheet
Set ws = Sheets("Sheet1")
For j = 2 To ws1.Range("a1000").End(xlUp).Row 'シート1の行分だけ繰り返す
Set ws = Sheets("Sheet" & CStr(Int(Val(ws1.Range("g" & j)) / 10) + 2)) '書き込みシートの指定
l = ((Val(ws1.Range("g" & j)) - 1) Mod 10) * 5 + 2 '書き込みシート内の列の指定
Select Case ws1.Range("g" & j)
Case "中"
d = 3
Case "小" 'パレット種による場合わけ
d = 5
End Select
c = ws1.Range("f" & j) 'ループで書き込むたびにパレット数を減らす(減らす前のパレット数)
k = 2 '書き始めの行位置
Do
If ws.Cells(k, l).Value = "" Then '記入があるか確認して
t = d
If c < d Then t = c 'tはコピペする行数
ws1.Range(ws1.Range("a" & j), ws1.Range("d" & j)).Copy ws.Range(ws.Cells(k, l), ws.Cells(k + t - 1, l + 3))
c = c - d '残りのパレット数
End If
If c <= 0 Then Exit Do 'パレット残数が0になったらループを抜ける
k = k + 6
Loop Until ws.Range("a10000").End(xlUp).Row < k '無限ループ回避(特に必要ない)1コース内2000列よりは少ないよね?
Next
End Sub
こんなかんじでしょうか。動作確認後に少しいじったので、動くかどうか分かりませんが。
質問者
お礼
お忙しい中、こんなに早くありがとうございます。
でも、残念ながら動きませんでした。
最初のForの行で
「実行時エラー'91'
オブジェクト変数、またはWithブロック変数が設定されていません。」
のエラーになります。
VBAの勉強は始めたばかりで、デバッグの仕方もわかりません。
自分でも見よう見まねで、以下のようなものを書きましたが、
これも動きません(^^;
困りました。
Dim comDate As String
Dim n As Integer
Sub 入庫管理()
Dim w As Worksheet
'Sheetを選択する
Worksheets("Sheet1").Activate
w = Worksheets("Sheet1").Cells(n, 7).Value
Select Case w
Case "1","2","3","4","5","6","7","8","9","10"
ws = Sheets("1-10")
Case "11","12","13","14","15","16","17","18","19","20"
ws = Sheets("11-20")
・
・
・
End Select
For n = 2 To 1000 '2から1000まで次の動作をくり返す
comDate = Sheets("Sheet1").Range(Cells(n, 1), Cells(n, 4)).Value 'Sheet1 n行1~4列の値
'Caseで振り分けたシートをアクティブにする
ws.Activate
'「コース」(列)を選択し、入力を開始する空白セルを選択する
If ws.Cells(3, 2) <> "" Then
'二行目から下の空白セルを探す
Do Until ActiveCell = ""
ActiveCell.Offset(6, 0).Select
Loop
End If
'comDateを三行ずつx回貼り付ける
Dim x As Integer
x = Worksheets("shieet1").Cells(n, 5).Value / 3
Do Until x
Sheets("Sheet1").Range(Cells(n, 1), Cells(n, 4)).Select
wrksht.Activate
Selection.Copy
For COUNTER = 0 To 3
ActiveCell.Offset(0, 0).Select
ActiveSheet.Paste
Next
ActiveCell.Offset(4, 0).Select
Loop
Next
End Sub
そもそも、私のは、「コース」の下限に来たときに折り返して次の「コース」に移ることもできていないし、そもそも文法が合っているかどうかもわかりません(^^;
お礼
動きました! ありがとうございました。 解決というわけではありませんが、参考にさせていただいて、もっと深めていこうと思います。 なんとか、仕事が軽減できればいいのですが・・・ ありがとうございました。