粘贴Excel VBA中
问题描述:
我有50个工作簿和我犯了一个代码从一个主一个行中哪个是corespondent名称其他49页的文件复制。问题在于粘贴到49个目标文件 - 粘贴方法不起作用。错误是当筛选器未找到名称条目时。我怎么能包括一行,如果过滤器没有在主文件中找到一个名字,它会在文件中粘贴“本月没有条目”,而这个名字是找不到的?谢谢。粘贴Excel VBA中
欢迎任何帮助。
Sub name1()
Dim ws As Worksheet
Dim rng As Range, rngA As Range, rngB As Range
Dim LRow As Long
Set ws = Sheets("name list")
With ws
LRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A1:M" & LRow)
.AutoFilterMode = False
With rng
.AutoFilter Field:=12, Criteria1:="name1"
Set rngA = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
End With
.AutoFilterMode = False
With rng
.AutoFilter Field:=13, Criteria1:="name1"
Set rngB = .Offset(1, 0).SpecialCells(xlCellTypeVisible)
End With
.AutoFilterMode = False
rng.Offset(1, 0).EntireRow.Hidden = True
Union(rngA, rngB).EntireRow.Hidden = False
End With
End Sub
Sub name11()
Dim lst As Long
Dim rng As Range
Dim i As Integer
Set rng = Application.Intersect(ActiveSheet.UsedRange, Range("A:M"))
rng.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Application.DisplayAlerts = False
Workbooks.Open Filename:= _
"\\HOFS\persons\name1.xlsm" _
, UpdateLinks:=true
With Sheets("tribute").Range("A" & Rows.Count).End(xlUp).Offset(1)
'.PasteSpecial Paste:=xlPasteColumnWidths
.PasteSpecial Paste:=xlPasteValues
End With
ActiveWorkbook.Close SaveChanges:=True
Application.DisplayAlerts = False
Windows("name list.xlsm").Activate
rng.Offset(1, 0).EntireRow.Hidden = False
End Sub
Sub TRANSFER_name1()
Call name1
Call name11
End Sub
答
单独设置最后一行。
' Gives the first empty row in column 1 (A)
lastRow = Worksheets("tribute").Cells(Worksheets("tribute").Rows.Count, 1).End(xlUp).Row + 1
' Pastes values
Worksheets("tribute").Range("A" & lastRow).PasteSpecial Paste:=xlPasteValues
+0
谢谢,这是一个很好的代码。 – wittman
答
它可能要好得多,以避免复制/粘贴的情况。随着时间的推移,这会花费超级时间。
尝试somethign像这个:
With Sheets("tribute").Range("A" & Rows.Count).End(xlUp).Offset(1).value = rng.Value
这是一个有点粗糙,但我相信你可以显著简化你的代码,如果你做的。
Dim wbk As Workbook
Dim Filename As String
Dim path As String
Dim rCell As Range
Dim rRng As Range
Dim wsO As Worksheet
Dim StartTime As Double
Dim SecondsElapsed As Double
Dim sheet As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
StartTime = Timer
path = "pathtofolder" & "\"
Filename = Dir(path & "*.xl??")
Set wsO = ThisWorkbook.Sheets("Sheet1")
Do While Len(Filename) > 0
DoEvents
Set wbk = Workbooks.Open(path & Filename, True, True)
Set rRng = sheet.Range("b1:b308")
For Each rCell In rRng.Cells
wsO.Cells(wsO.Rows.count, 1).End(xlUp).Offset(1, 0).Value = rCell
Next rCell
wbk.Close False
Filename = Dir
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
+0
谢谢,这是一段很好的代码。 – wittman
“不工作” 怎么样? – SiHa
问题是更新链接,所以我改变了,现在它的作品。但它过滤器没有在列表中找到名称,代码停止。我怎么能包括一行,如果过滤器没有在主文件中找到一个名字,它会在文件中粘贴“本月没有条目”,而这个名字是找不到的?谢谢。 – wittman