根据单元格内容将部分数据行从一个工作表复制到同一工作簿中的新工作表

1 回答

• 1

  这样的事情应该让你开始 . 我试图对它进行彻底的评论，以便解释宏中发生的事情：

  Sub CopySomeCells()
  Dim targetSheet As Worksheet 'destination for the copied cells'
  Dim sourceSheet As Worksheet 'source of data worksheet'
  Dim rng As Range 'range variable for all data'
  Dim rngToCopy As Range 'range to copy'
  Dim r As Long 'row counter'
  Dim x As Long 'row finder'
  Dim clientCode As String
  Dim clientSheet As String
  
  Set sourceSheet = Worksheets("Sheet1") '## The source data worksheet, modify as needed ##
      With sourceSheet
          '## the sheet may have data between rows 4 and 1000, modify as needed ##'
          Set rng = .Range("A4", Range("A1000").End(xlUp))
  
          '## iterate over the rows in the range we defined above ##'
          For r = 1 To rng.Rows.Count
  
  
              '## Set the range to copy ##'
              Set rngToCopy = Range(rng.Cells(r, 1), rng.Cells(r, 12))
  
              '## ignore rows that don't have a value in column F ##
              If Not rng.Cells(r, 6).Value = vbNullString Then
  
                  '## Set the targetSheet dynamically, based on the code in column F ##'
                  '  e.g., "ab1" --> Client 1, "ab2" --> Client 2, etc. '
                  '## Set the client code ##"
                  clientCode = rng.Cells(r, 6).Value
  
                  '## determine what sheet to use ##'
                  ' I do this by finding the client code in the lookup table, which
                  ' is in range "O24:O37", using the MATCH function.
                  ' Then, offset it -1 rows (the row above) which will tell us "Client Code 1", etc.
  
                  clientSheet = .Range("O23").Offset( _
                      Application.Match(clientCode, .Range("O24:O37"), False), 0).Offset(-1, 0).Value
                  ' take that value "Client Code 1" and replace "Code " with nothing, so that
                  ' will then give us the sheet name, e.g., "Client Code 1" --> "Client 1", etc. ##'
                  clientSheet = Replace(clientSheet, "Code ", vbNullString)
  
                  Set targetSheet = Worksheets(clientSheet)
  
                  '## Find the next empty row in this worksheet ##'
                  x = Application.WorksheetFunction.CountA(targetSheet.Range("A:A")) + 1
  
                  '## Copy the selected sub-range, ##'
  
                  rngToCopy.Copy 
  
                  '## Paste values only to the target sheet ##'
                  targetSheet.Cells(x, 1).PasteSpecial Paste:=xlPasteValues, _
                      Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  
              End If
  
          Next '## proceed to process the next row in this range ##'
  
      End With
  
  End Sub
  

  回复于 2024-04-28T21:47:13+08:00