Sub copyreport()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.DisplayAlerts = False
Dim wb, wb2 As Workbook
Dim myFile As String, i As Long, lc As Long, lr As Long, lr1 As Long
If LCase(get_R1_Run_by_Robot) = "y" Then thsmn.Range("B3") = vcrparms.Cells(5, "B")
thswbk.Sheets("WD").Cells.Clear
myFile = thsmn.Range("B3").Value
If thsmn.Range("B3") <> "" Then
Set wb = Workbooks.Open(fileName:=myFile)
wb.Sheets("Bank Details Report").Range("A1:Z60000").Copy
thswbk.Sheets("WD").Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
wb.Sheets("Bank Details Report").Range("A1:Z60000").Copy
thswbk.Sheets("WD").Range("A1").PasteSpecial xlPasteAllUsingSourceTheme
wb.Sheets("Bank Details Report").Range("A1:Z60000").Copy
thswbk.Sheets("WD").Range("A1").PasteSpecial xlPasteColumnWidths
wb.Close False
If LCase(get_R1_Run_by_Robot) = "n" Then MsgBox "Workday file has been uploaded!"
End If
thswbk.Sheets("Manual-Run").Activate
' Deleting the blank rows
lr = thswbk.Sheets("WD").Cells(Rows.Count, 1).End(xlUp).Row
lr1 = thswbk.Sheets("WD").Cells(lr, 1).End(xlUp).Row - 1 '可以定位到数据区域的空行
Do Until lr1 < 1 '所有涉及到删除行数据的操作都不要使用 for each和for range循环,会有指针问题导致的删错行。
thswbk.Sheets("WD").Cells(lr1, 1).EntireRow.Delete '删除空行
lr1 = lr1 - 1
Loop
' Adding New Formulas
i = 2
lr = thswbk.Worksheets("WD").Cells(Rows.Count, "A").End(xlUp).Row
Do Until cfgsht.Cells(i, "O") = ""
If cfgsht.Cells(i, "O") = "WD" Then
lc = thswbk.Sheets("WD").Cells(1, Columns.Count).End(xlToLeft).Column + 1
thswbk.Sheets("WD").Cells(1, lc) = cfgsht.Cells(i, "R")
thswbk.Sheets("WD").Cells(1, lc - 1).Copy
thswbk.Sheets("WD").Cells(1, lc).PasteSpecial xlPasteFormats
thswbk.Sheets("WD").Cells(1, lc).EntireColumn.ColumnWidth = 20
Application.CutCopyMode = False
thswbk.Sheets("WD").Cells(2, lc) = "=" & cfgsht.Cells(i, "Q")
thswbk.Sheets("WD").Cells(2, lc).AutoFill thswbk.Sheets("WD").Range(thswbk.Sheets("WD").Cells(2, lc), thswbk.Sheets("WD").Cells(lr, lc))
End If
i = i + 1
Loop
End Sub
有用的代码 2: