改进复制/粘贴的代码

我需要减less代码在哪里我多次写入synatx复制和粘贴行值。

Private Sub btn_upload_Click() 'Frm_Mainform.Show 'MsgBox ("Process Complete - Please Check File in Output Folder") Const FOLDER As String = "C:\SBI_Files\" On Error GoTo ErrorHandler Dim i As Integer i = 18 Dim fileName As String fileName = Dir(FOLDER, vbDirectory) Do While Len(fileName) > 0 If Right$(fileName, 4) = "xlsx" Or Right$(fileName, 3) = "xls" Then i = i + 1 Dim currentWkbk As Excel.Workbook Set currentWkbk = Excel.Workbooks.Open(FOLDER & fileName) Cells(i, 1) = fileName Cells(i + 1, 2) = "Equity" Cells(i + 2, 2) = "Forex NOOP" Cells(i + 3, 2) = "Fixed Income Securities ( including CP, CD, G Sec)" Cells(i + 4, 2) = "Total" Cells(i, 2) = "Details" Cells(i, 3) = "Limit" Cells(i, 4) = "Min Var" Cells(i, 5) = "Max Var" Cells(i, 6) = "No. of Breaches" Cells(i + 1, 3) = currentWkbk.Sheets("VaR").Range("G8:G8").Value Cells(i + 1, 4) = currentWkbk.Sheets("VaR").Range("H8:H8").Value Cells(i + 1, 5) = currentWkbk.Sheets("VaR").Range("I8:I8").Value Cells(i + 1, 6) = currentWkbk.Sheets("VaR").Range("J8:J8").Value i = i + 1 Cells(i + 1, 3) = currentWkbk.Sheets("VaR").Range("G9:G9").Value Cells(i + 1, 4) = currentWkbk.Sheets("VaR").Range("H9:H9").Value Cells(i + 1, 5) = currentWkbk.Sheets("VaR").Range("I9:I9").Value Cells(i + 1, 6) = currentWkbk.Sheets("VaR").Range("J9:J9").Value i = i + 1 Cells(i + 1, 3) = currentWkbk.Sheets("VaR").Range("G10:G10").Value Cells(i + 1, 4) = currentWkbk.Sheets("VaR").Range("H10:H10").Value Cells(i + 1, 5) = currentWkbk.Sheets("VaR").Range("I10:I10").Value Cells(i + 1, 6) = currentWkbk.Sheets("VaR").Range("J10:J10").Value i = i + 1 Cells(i + 1, 3) = currentWkbk.Sheets("VaR").Range("G11:G11").Value Cells(i + 1, 4) = currentWkbk.Sheets("VaR").Range("H11:H11").Value Cells(i + 1, 5) = currentWkbk.Sheets("VaR").Range("I11:I11").Value Cells(i + 1, 6) = currentWkbk.Sheets("VaR").Range("J11:J11").Value i = i + 1 currentWkbk.Close End If fileName = Dir Loop ProgramExit: Exit Sub ErrorHandler: MsgBox Err.Number & " - " & Err.Description Resume ProgramExit End Sub 

Answer 1

您可以用这4个replace所有的Cells行

更新：为应对格式添加行

  'other code Set currentWkbk = Excel.Workbooks.Open(FOLDER & fileName) Cells(i, 1) = fileName Cells(i + 1, 2).Resize(4, 1) = Application.Transpose(Array("Equity", "Forex NOOP", "Fixed Income Securities ( including CP, CD, G Sec)", "Total")) Cells(i, 2).Resize(1, 5) = Array("Details", "Limit", "Min Var", "Max Var", "No. of Breaches") Cells(i + 1, 3).Resize(4, 4) = currentWkbk.Sheets("VaR").Range("G8:J11").Value currentWkbk.Sheets("VaR").Range("G8:J11").Copy Cells(i + 1, 3) currentWkbk.Close