在不同的 sheet 中粘贴信息（希望在每个 sheet 中指定从单元格 A1 开始）
Paste information in different sheets (would like to specify started at cell A1 in each sheet)
excel sheet1 中有 3 组数据 (A,B,C)，在我的工作簿中我已经创建了 3 个 sheet 命名为 (A, B , C).
我把A、B、C组数据复制到它们对应的sheet没问题，例如将 A 组数据复制到 sheet A 中，但是我发现在某些情况下，每个 sheet 开头的选定单元格不在 A1 中，例如开头选定的单元格可能位于 excel 中的其他单元格（例如 B10），这使演示文稿看起来很乱，我希望每个 sheet 中的所有数据都从 A1 开始。我知道你们中的一些人可能会说使用代码 Range("a1").selected 可以处理这种情况，但是我们需要使用“Do loop”循环遍历 sheet1 中的每一行以识别该行是属于A，B或C，然后我们将该行粘贴到相应的sheet中。我发现如果我包含代码 Range("a1").selected，那么每次程序都会将 Sheet1 中的行粘贴到 sheet A、B 和 C 中的单元格 A1 中，最后只会有每 sheet 出现一行。我应该如何改进下面的程序，以便每次在他们的工作sheet中每个组中的数据都可以出现在单元格A1的开头，甚至有时每个sheet的选定单元格不在单元格A1中？谢谢
Sub data_category()
Dim y As Integer
Dim x As String
Sheets("sheet1").Activate
Range("a3").Select
Do Until ActiveCell.Value = ""
y = ActiveCell.Offset(0, 3).Value
If y < 90 Then
x = "A"
ElseIf y < 120 Then
x = "B"
Else
x = "C"
End If
ActiveCell.Offset(0, 4).Value = x
Range(ActiveCell, ActiveCell.End(xlToRight)).Copy
Sheets(x).Activate
Range("a1").Select
ActiveCell.PasteSpecial
ActiveCell.Offset(1, 0).Select
Sheets("sheet1").Activate
ActiveCell.Offset(1, 0).Select
Loop
End Sub
根据 Sid 的评论：
Sub data_category()
Dim y As Long
Dim x As String, c As Range, ws As Worksheet, wb As Workbook, cDest As Range
Set wb = ActiveWorkbook 'or ThisWorkbook: always good to be specific here
Set c = wb.Worksheets("sheet1").Range("a3") 'get a reference to the starting cell
Do Until Len(c.Value) = 0
y = c.Offset(0, 3).Value
Select Case y 'tidier then if...else if
Case Is < 90: x = "A"
Case Is < 120: x = "B"
Case Else: x = "C"
End Select
c.Offset(0, 4).Value = x
'direct copy to next empty row with no select/activate
Set cDest = wb.Worksheets(x).Cells(Rows.Count, 1).End(xlUp)
If Len(cDest).Value > 0 Then Set cDest = cDest.Offset(1, 0)
c.EntireRow.Copy cDest
Set c = c.Offset(1,0) '<<<<<<<<<<<<< edit - added
Loop
c.Parent.Activate
End Sub
与 Do-Loop 方法不同，为了 执行速度更快 .
逻辑
- 找到第
Sheet1 列的最后一行 A
- 从行
3 开始，在列 E 中插入公式 =IF(D3<90,"A",IF(D3<120,"B","C"))
- 接下来我将首先使用自动筛选器筛选
A 上的列E，然后将所有数据一次性复制到Sheet A。我将重复 B 和 C 的过程
我的假设
- 第 2 行有 headers。如果不是，请相应地调整代码。
代码
我已经对代码进行了注释，因此您在理解它时不会有问题，但如果您理解了，请直接提问。
Option Explicit
Dim ws As Worksheet
Dim rng As Range
Sub Sample()
Set ws = ThisWorkbook.Sheets("Sheet1")
Dim lRow As Long
With ws
'~~> Remove any filters
.AutoFilterMode = False
'~~> Find last row
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Insert formula in Col E
With .Range("E3:E" & lRow)
.Formula = "=IF(D3<90,""A"",IF(D3<120,""B"",""C""))"
.Value = .Value
End With
'~~> Identify the range to work with
Set rng = .Range("A2:E" & lRow)
'~~> Copy rows with relevant criteria
CopyData "A"
CopyData "B"
CopyData "C"
.AutoFilterMode = False
End With
End Sub
Private Sub CopyData(shName As String)
Dim rngToCopy As Range
'~~> Filter column E on the search string
With rng
.AutoFilter Field:=5, Criteria1:=shName
Set rngToCopy = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
'~~> Copy all data in one go
If Not rngToCopy Is Nothing Then rngToCopy.Copy ThisWorkbook.Sheets(shName).Rows(1)
ws.AutoFilterMode = False
End Sub
在行动
更新类别报告
Option Explicit
Sub UpdateCategoryReports()
Const sfRow As Long = 3 ' First Row (headers are in row 'sfRow - 1')
Const sfCol As Long = 1
Const dfRow As Long = 2 ' First Row (headers are in row 'dfRow - 1')
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
If slRow < sfRow Then Exit Sub ' no data (highly unlikely)
Dim slCol As Long
slCol = sws.Cells(sfRow - 1, sws.Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False
Dim dws As Worksheet ' Destination Worksheet
Dim durg As Range ' Destination 'UsedRange'
Dim dcrg As Range ' Destination Clear Range
' Clear destination data.
For Each dws In wb.Worksheets(Array("A", "B", "C"))
Set durg = dws.UsedRange ' Destination Used Range
If durg.Rows.Count > 1 Then
' You don't want to clear the headers:
' e.g. if 'durg' is 'A1:J10' then 'dcrg' will be 'A2:J10'.
Set dcrg = durg.Resize(durg.Rows.Count - 1).Offset(1)
dcrg.Clear
End If
Next dws
Dim srrg As Range ' Source Row Range
Dim sRow As Long ' Source Row
Dim dfCell As Range ' Destination First Cell (Range)
Dim dRow As Long ' Destination (Available) Row
Dim sValue As Double ' Source Value
Dim dwsName As String ' Destination Worksheet Name
For sRow = sfRow To slRow
If IsNumeric(sws.Cells(sRow, "D").Value) Then
sValue = sws.Cells(sRow, "D").Value
If sValue < 90 Then
dwsName = "A"
ElseIf sValue < 120 Then
dwsName = "B"
Else
dwsName = "C"
End If
Set srrg = sws.Range(sws.Cells(sRow, "A"), sws.Cells(sRow, slCol))
sws.Cells(sRow, "E").Value = dwsName ' ?
Set dws = wb.Worksheets(dwsName)
dRow = dws.Cells(dws.Rows.Count, "A").End(xlUp).Row + 1
Set dfCell = dws.Cells(dRow, "A")
' This will copy values, formats, and formulas. You may need another
' way. If there are formulas in source and you only need values,
' copying by assignment is the most efficient way. If you also need
' the formats you will have to use the least efficient PasteSpecial.
srrg.Copy Destination:=dfCell
'Else ' sValue is not numeric: do nothing
End If
Next sRow
'sws.Activate
'sws.Cells(1).Activate
Application.ScreenUpdating = True
MsgBox "Category reports updated.", vbInformation, "Category Reports"
End Sub
excel sheet1 中有 3 组数据 (A,B,C)，在我的工作簿中我已经创建了 3 个 sheet 命名为 (A, B , C).
我把A、B、C组数据复制到它们对应的sheet没问题，例如将 A 组数据复制到 sheet A 中，但是我发现在某些情况下，每个 sheet 开头的选定单元格不在 A1 中，例如开头选定的单元格可能位于 excel 中的其他单元格（例如 B10），这使演示文稿看起来很乱，我希望每个 sheet 中的所有数据都从 A1 开始。我知道你们中的一些人可能会说使用代码 Range("a1").selected 可以处理这种情况，但是我们需要使用“Do loop”循环遍历 sheet1 中的每一行以识别该行是属于A，B或C，然后我们将该行粘贴到相应的sheet中。我发现如果我包含代码 Range("a1").selected，那么每次程序都会将 Sheet1 中的行粘贴到 sheet A、B 和 C 中的单元格 A1 中，最后只会有每 sheet 出现一行。我应该如何改进下面的程序，以便每次在他们的工作sheet中每个组中的数据都可以出现在单元格A1的开头，甚至有时每个sheet的选定单元格不在单元格A1中？谢谢
Sub data_category()
Dim y As Integer
Dim x As String
Sheets("sheet1").Activate
Range("a3").Select
Do Until ActiveCell.Value = ""
y = ActiveCell.Offset(0, 3).Value
If y < 90 Then
x = "A"
ElseIf y < 120 Then
x = "B"
Else
x = "C"
End If
ActiveCell.Offset(0, 4).Value = x
Range(ActiveCell, ActiveCell.End(xlToRight)).Copy
Sheets(x).Activate
Range("a1").Select
ActiveCell.PasteSpecial
ActiveCell.Offset(1, 0).Select
Sheets("sheet1").Activate
ActiveCell.Offset(1, 0).Select
Loop
End Sub
根据 Sid 的评论：
Sub data_category()
Dim y As Long
Dim x As String, c As Range, ws As Worksheet, wb As Workbook, cDest As Range
Set wb = ActiveWorkbook 'or ThisWorkbook: always good to be specific here
Set c = wb.Worksheets("sheet1").Range("a3") 'get a reference to the starting cell
Do Until Len(c.Value) = 0
y = c.Offset(0, 3).Value
Select Case y 'tidier then if...else if
Case Is < 90: x = "A"
Case Is < 120: x = "B"
Case Else: x = "C"
End Select
c.Offset(0, 4).Value = x
'direct copy to next empty row with no select/activate
Set cDest = wb.Worksheets(x).Cells(Rows.Count, 1).End(xlUp)
If Len(cDest).Value > 0 Then Set cDest = cDest.Offset(1, 0)
c.EntireRow.Copy cDest
Set c = c.Offset(1,0) '<<<<<<<<<<<<< edit - added
Loop
c.Parent.Activate
End Sub
与 Do-Loop 方法不同，为了 执行速度更快 .
逻辑
- 找到第
Sheet1列的最后一行A - 从行
3 开始，在列 - 接下来我将首先使用自动筛选器筛选
A上的列E，然后将所有数据一次性复制到SheetA。我将重复B和C 的过程
E 中插入公式 =IF(D3<90,"A",IF(D3<120,"B","C"))
我的假设
- 第 2 行有 headers。如果不是，请相应地调整代码。
代码
我已经对代码进行了注释，因此您在理解它时不会有问题，但如果您理解了，请直接提问。
Option Explicit
Dim ws As Worksheet
Dim rng As Range
Sub Sample()
Set ws = ThisWorkbook.Sheets("Sheet1")
Dim lRow As Long
With ws
'~~> Remove any filters
.AutoFilterMode = False
'~~> Find last row
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Insert formula in Col E
With .Range("E3:E" & lRow)
.Formula = "=IF(D3<90,""A"",IF(D3<120,""B"",""C""))"
.Value = .Value
End With
'~~> Identify the range to work with
Set rng = .Range("A2:E" & lRow)
'~~> Copy rows with relevant criteria
CopyData "A"
CopyData "B"
CopyData "C"
.AutoFilterMode = False
End With
End Sub
Private Sub CopyData(shName As String)
Dim rngToCopy As Range
'~~> Filter column E on the search string
With rng
.AutoFilter Field:=5, Criteria1:=shName
Set rngToCopy = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
'~~> Copy all data in one go
If Not rngToCopy Is Nothing Then rngToCopy.Copy ThisWorkbook.Sheets(shName).Rows(1)
ws.AutoFilterMode = False
End Sub
在行动
更新类别报告
Option Explicit
Sub UpdateCategoryReports()
Const sfRow As Long = 3 ' First Row (headers are in row 'sfRow - 1')
Const sfCol As Long = 1
Const dfRow As Long = 2 ' First Row (headers are in row 'dfRow - 1')
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
If slRow < sfRow Then Exit Sub ' no data (highly unlikely)
Dim slCol As Long
slCol = sws.Cells(sfRow - 1, sws.Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False
Dim dws As Worksheet ' Destination Worksheet
Dim durg As Range ' Destination 'UsedRange'
Dim dcrg As Range ' Destination Clear Range
' Clear destination data.
For Each dws In wb.Worksheets(Array("A", "B", "C"))
Set durg = dws.UsedRange ' Destination Used Range
If durg.Rows.Count > 1 Then
' You don't want to clear the headers:
' e.g. if 'durg' is 'A1:J10' then 'dcrg' will be 'A2:J10'.
Set dcrg = durg.Resize(durg.Rows.Count - 1).Offset(1)
dcrg.Clear
End If
Next dws
Dim srrg As Range ' Source Row Range
Dim sRow As Long ' Source Row
Dim dfCell As Range ' Destination First Cell (Range)
Dim dRow As Long ' Destination (Available) Row
Dim sValue As Double ' Source Value
Dim dwsName As String ' Destination Worksheet Name
For sRow = sfRow To slRow
If IsNumeric(sws.Cells(sRow, "D").Value) Then
sValue = sws.Cells(sRow, "D").Value
If sValue < 90 Then
dwsName = "A"
ElseIf sValue < 120 Then
dwsName = "B"
Else
dwsName = "C"
End If
Set srrg = sws.Range(sws.Cells(sRow, "A"), sws.Cells(sRow, slCol))
sws.Cells(sRow, "E").Value = dwsName ' ?
Set dws = wb.Worksheets(dwsName)
dRow = dws.Cells(dws.Rows.Count, "A").End(xlUp).Row + 1
Set dfCell = dws.Cells(dRow, "A")
' This will copy values, formats, and formulas. You may need another
' way. If there are formulas in source and you only need values,
' copying by assignment is the most efficient way. If you also need
' the formats you will have to use the least efficient PasteSpecial.
srrg.Copy Destination:=dfCell
'Else ' sValue is not numeric: do nothing
End If
Next sRow
'sws.Activate
'sws.Cells(1).Activate
Application.ScreenUpdating = True
MsgBox "Category reports updated.", vbInformation, "Category Reports"
End Sub