![](/img/trans.png)
[英]Copying a range of cells in a column in one sheet to specified cells in a row in another
[英]copying variable range of cells from one sheet to another
我有12張紙,里面有信息。 我想將每張紙上的某些信息整理到一張紙上。
所以,
我首先找出要處理的行數,然后將前兩列復制到另一張表(結果)中。
現在,我可以從每張紙上復制第一列,但是不能鍛煉我在做錯了什么也無法復制第二列。
Sub loopMe()
Dim Jan As Worksheet, Feb As Worksheet, Mar As Worksheet, Apr As Worksheet, May As Worksheet, Jun As Worksheet
Dim Jul As Worksheet, Aug As Worksheet, Sep As Worksheet, October As Worksheet, Nov As Worksheet, Dec As Worksheet
Dim LstR As Long, rngJan As Range, c As Range, rngFeb As Range, rngMar As Range, rngApr As Range
Dim rngMay As Range, rngJun As Range, rngJul As Range, rngAug As Range, rngSep As Range, rngOctober As Range
Dim rngNov As Range, rngDec As Range
Set Jan = Sheets("January") 'set the sheet to loop
With Jan 'do something with the sheet
LstR = .Cells(.Rows.Count, "A").End(xlUp).Row 'find last row
Set rngJan = .Range("A2:B" & LstR) 'set range to loop
End With
Set Feb = Sheets("February") 'set the sheet to paste
With Feb 'do something with the sheet
LstR = .Cells(.Rows.Count, "A").End(xlUp).Row 'find last row
Set rngFeb = .Range("A2:B" & LstR) 'set range to loop
End With
'以上應該設置每張紙中的數據范圍(希望如此)'然后運行以下命令
For Each y In rngJan
Worksheets("Results").Range("A65536").End(xlUp).Offset(1, 0).Value = y.Value
Next y
For Each y In rngFeb
Worksheets("Results").Range("A65536").End(xlUp).Offset(1, 0).Value = y.Value
Next y
我需要的信息存儲在A和B列中,因此它們是我試圖復制的內容。
誰能幫忙?
嘗試這個:
首先,您只想遍歷A列。
然后將范圍設置為兩列,使用y和y.offset聲明范圍很容易。 目標使用resize(,2)。
Sub loopMe()
Dim Jan As Worksheet, Feb As Worksheet, Mar As Worksheet, Apr As Worksheet, May As Worksheet, Jun As Worksheet
Dim Jul As Worksheet, Aug As Worksheet, Sep As Worksheet, October As Worksheet, Nov As Worksheet, Dec As Worksheet
Dim LstR As Long, rngJan As Range, c As Range, rngFeb As Range, rngMar As Range, rngApr As Range
Dim rngMay As Range, rngJun As Range, rngJul As Range, rngAug As Range, rngSep As Range, rngOctober As Range
Dim rngNov As Range, rngDec As Range
Set Jan = Sheets("January") 'set the sheet to loop
With Jan 'do something with the sheet
LstR = .Cells(.Rows.Count, "A").End(xlUp).Row 'find last row
Set rngJan = .Range("A2:A" & LstR) 'set range to loop
End With
Set Feb = Sheets("February") 'set the sheet to paste
With Feb 'do something with the sheet
LstR = .Cells(.Rows.Count, "A").End(xlUp).Row 'find last row
Set rngFeb = .Range("A2:A" & LstR) 'set range to loop
End With
' The above should set the range of data in each sheet (I hope) ' Then I run the following
For Each y In rngJan
Worksheets("Results").Range("A65536").End(xlUp).Offset(1, 0).resize(,2).Value = Range(y, y.Offset(, 1)).Value
Next y
For Each y In rngFeb
Worksheets("Results").Range("A65536").End(xlUp).Offset(1, 0).resize(,2).Value = Range(y, y.Offset(, 1)).Value
Next y
End Sub
嘗試使用此代碼可有效使用For...Next
語句,避免過多使用對象變量。 它會在繼續復制數據之前清除先前的數據,還包括錯誤處理,以防工作表被刪除或預期名稱更改。 試圖通過代碼中的注釋使其易於解釋,但是請務必告訴我您可能遇到的任何問題。
Sub Copy_Months_Data()
Const kRowIni As Byte = 2 'Constant to hold the starting row, easy to update if required
Dim aMonths As Variant
aMonths = Array("January", "February", "March", "April", _
"May", "June", "July", "August", _
"September", "October", "November", "December")
Dim WshSrc As Worksheet, WshTrg As Worksheet
Dim rSrc As Range
Dim lRowLst As Long, lRowNxt As Long
Dim vItm As Variant
On Error GoTo ErrHdlr
Application.ScreenUpdating = 0
Application.EnableEvents = 0
With ThisWorkbook 'Procedure is resident in data workbook
'With Workbooks(WbkName) 'Procedure is no resident in data workbook
Rem Set & Prepare Target Worksheet - Results
vItm = "Results"
Set WshTrg = .Sheets(vItm) 'Change sheet name as required
With WshTrg
Application.Goto .Cells(1), 1
Rem Clear Prior Data
.Columns("A:B").ClearContents
lRowNxt = kRowIni
End With
For Each vItm In aMonths
Rem Set Source Worksheet - Each month
Set WshSrc = .Sheets(vItm)
With WshSrc
Rem Set Last Row for Columns A & B
lRowLst = .Cells(.Rows.Count, "A").End(xlUp).Row
If .Cells(.Rows.Count, "B").End(xlUp).Row > lRowLst Then _
lRowLst = .Cells(.Rows.Count, "B").End(xlUp).Row
Set rSrc = .Range(.Cells(kRowIni, 1), .Cells(lRowLst, 2))
End With
Rem Copy Range Values to Target Worksheet
With rSrc
WshTrg.Cells(lRowNxt, 1).Resize(.Rows.Count, .Columns.Count).Value = .Value2
lRowNxt = lRowNxt + .Rows.Count
End With
Next: End With
Application.ScreenUpdating = 1
Application.EnableEvents = 1
Exit Sub
ErrHdlr:
MsgBox prompt:="Process failed while processing worksheet """ & vItm & """ due to: " & vbLf & _
vbTab & "Err: " & Err.Number & vbLf & _
vbTab & "Dsc: " & Err.Description, _
Buttons:=vbCritical + vbApplicationModal, _
Title:="Copy Months Data"
Application.ScreenUpdating = 1
Application.EnableEvents = 1
End Sub
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.