0
親切な質問（VBA migrating data from different worksheets to one worksheet at specific locations）に続いて、他のコード研究者の投稿に基づいて以下のコードを編集しました。専門家。条件に基づいて別のワークシートの不連続列から非連続列へのデータのコピー/貼り付け
以前のコード（リンクを参照）は、実行時エラーが発生する特定のポイントまで機能していました。私はその提案に従って、削除しました。コピー＆ペースト操作からアクティブにすることができますが、現在以下のコードは、「フィードストックレコードシートからコピーする」という点から何もしません。私は間違ったやり方をしていると思いますが、私は別の方法で問題に近づくことができますが、私は解決策を見つけるのに苦労しています。誰にもアイデアはありますか？
デバッグ後、私は日付に定義されているが、セルの順序を変えてしまったというエラー13を克服することができました。しかし、私は以下のコメントに記載されているエラー1004を知っています（私の最後のコメントを参照）。この問題を解決する方法を誰かが知っているかどうかは疑問でした。私はエラーが表示される箇所にマークを付けました（2番目のループにあります）。 sht5の日付は2015年1月1日からのみ開始されますが、sht4は2014年7月8日から開始されます。 2014年の最初の日に問題を修正した後、コードはの太字ので指定された範囲を過ぎたときに値01/01/2015に達するまで実行することができました。誰でも助けてくれますか？あなたは、ループ内のmonthsi、monthsjとmonthskの設定を持参することをお勧めしますようおかげで
Option Explicit
Sub main()
'open/close worksheets from huddle folder and teamviewer'
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim Wb3 As Workbook
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim sht3 As Worksheet
Dim sht4 As Worksheet
Dim sht5 As Worksheet
Dim i As Long, j As Long, k As Long, lastrow1 As Long, lastrow2 As Long, lastrow3 As Long
Dim monthsi As Date, monthsk As Date, monthsj As Date
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
Set Wb1 = Workbooks.Open("U:\Data from plants\Huddle\EEL Feedstock Records - NEW VERSION.xlsx")
Set Wb2 = Workbooks.Open("U:\Data from plants\Teamviewer\EE.xlsx")
Set Wb3 = ThisWorkbook
Set sht1 = Wb1.Sheets("Feedstock Usage (Non-beet site)")
Set sht2 = Wb2.Sheets("Sheet1")
Set sht3 = Wb3.Sheets("Feedstock records")
Set sht4 = Wb3.Sheets("Teamviewer")
Set sht5 = Wb3.Sheets("Plants data")
sht3.Cells.Delete Shift:=xlUp
sht4.Cells.Delete Shift:=xlUp
sht1.Cells.Copy
sht3.Range("A1").PasteSpecial xlPasteAll
Application.CutCopyMode = False
Wb1.Close False
sht2.Cells.Copy
sht4.Range("A1").PasteSpecial xlPasteAll
Application.CutCopyMode = False
Wb2.Close False
'copy from feedstock records sheet'
lastrow1 = sht3.Range("C" & Rows.Count).End(xlUp).Row
i = 10
lastrow2 = sht4.Range("A" & Rows.Count).End(xlUp).Row
k = 4
lastrow3 = sht5.Range("A" & Rows.Count).End(xlUp).Row
j = 5
Do
monthsi = sht3.Cells(i, "C").Value
If sht5.Cells(j, "A").Value = monthsi Then
sht3.Range(Cells(i, "D"), Cells(i, "E")).Copy
sht5.Range(Cells(j, "VE"), Cells(j, "VF")).PasteSpecial xlPasteValues
sht3.Range(Cells(i, "G"), Cells(i, "H")).Copy
sht5.Range(Cells(j, "VI"), Cells(j, "VJ")).PasteSpecial xlPasteValues
sht3.Range(Cells(i, "J"), Cells(i, "K")).Copy
sht5.Range(Cells(j, "VM"), Cells(j, "VN")).PasteSpecial xlPasteValues
sht3.Range(Cells(i, "M"), Cells(i, "N")).Copy
sht5.Range(Cells(j, "VY"), Cells(j, "VZ")).PasteSpecial xlPasteValues
sht3.Range(Cells(i, "P"), Cells(i, "Q")).Copy
sht5.Range(Cells(j, "VQ"), Cells(j, "VR")).PasteSpecial xlPasteValues
End If
i = i + 1
Loop Until i = lastrow1 + 1
Do
monthsk = sht4.Cells(k, "A").Value
If sht5.Cells(j, "A").Value = monthsk Then
sht4.Cells(k, "H").Copy
sht5.Cells(j, "XW").PasteSpecial xlPasteValues
sht4.Cells(k, "I").Copy
sht5.Cells(j, "YJ").PasteSpecial xlPasteValues
sht4.Range(Cells(k, "J"), Cells(k, "O")).Copy
**sht5.Range(Cells(j, "ZK"), Cells(j, "ZP")).PasteSpecial xlPasteValues**
sht4.Cells(k, "U").Copy
sht5.Cells(j, "XU").PasteSpecial xlPasteValues
sht4.Cells(k, "X").Copy
sht5.Cells(j, "XV").PasteSpecial xlPasteValues
sht4.Cells(k, "Y").Copy
sht5.Cells(j, "YH").PasteSpecial xlPasteValues
sht4.Cells(k, "AB").Copy
sht5.Cells(j, "YI").PasteSpecial xlPasteValues
sht4.Range(Cells(k, "AN"), Cells(i, "AP")).Copy
sht5.Range(Cells(j, "XR"), Cells(j, "XT")).PasteSpecial xlPasteValues
sht4.Cells(k, "AQ").Copy
sht5.Cells(j, "XQ").PasteSpecial xlPasteValues
End If
k = k + 1
Loop Until k = lastrow2 + 1
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
'Loop Until'ステートメントには' j = lastrow3 + 1'がありますが、ループ内のどこに 'j'をインクリメントしているのかわかりません。 – PartyHatPanda