时间戳

首页 > 解决方案 > vba代码查找预定范围，复制和转置

excel - vba代码查找预定范围，复制和转置

问题描述

我正在处理一个包含多个单独数据的 excel 文档，所有数据都在一个列中（A1 到 A10160）。

所有数据都以文本 NC/xx/xxxx/x（x 为变量）的单元格开始，并以包含不同日期的单元格结束，但其上方的单元格始终具有文本“开始日期”。一些数据涵盖 49 个单元格，其他数据涵盖 51 个单元格，因此它不包含在列中固定数量的单元格中。

我需要复制从 NC/xx/xxxx/x 到开始日期的范围，每个数据“集”加一个，转置它并将列中的所有数据粘贴到新工作表中。

到目前为止真的没有发现任何有用的东西，但我正在摸索这个：

Sub Find()
Dim Search, End, Start, i As Integer, j As Integer, L
    Search = Cells(1, 1)
    End = Cells(2, 1)
    For i = 1 To 10160
        If Left(Cells(i, 1), 3) = Search Then
            Start = i - 0
        End If
    Next i
    For j = 1 To 10160
    If Cells(j, 1) = End Then
            L = j + 1
        End If
            Sheet4.Select
            Range(Cells(Start, 1), Cells(L + 2, 1)).Select
            Selection.Copy
            Sheet4.Range("BB23").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        Application.CutCopyMode = False
    End
    Next j
    
End Sub

非常感谢我能得到的任何帮助！

谢谢！

标签： excelvba

解决方案

看来您对您的问题没有太大兴趣，所以我看了一下。这是其中一项繁琐的工作——技术性不是很强，但要正确处理逻辑流却很棘手。下面的代码为您提供了您在问题中概述的内容。你已经说过transpose it- 这就是代码的作用。试试看，让我知道你的情况。

    Option Explicit
    Sub Copy2Sheet2()
    'Declare all your variables
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim topRow As Long, BottomRow As Long, LastRow As Long
    Dim PasteToRow As Long, i As Long, c As Range
    
    'Set the sheet variables
    Set ws1 = Sheets(1)
    Set ws2 = Sheets(2)
    
    'Initial row settings
    LastRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    PasteToRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1 '<~~ assumes headers on sheet2
    
    'Start the loop
    For i = 1 To LastRow   
        'Find the bottom row of the first block of data
        Set c = ws1.Range("A" & i & ":A" & LastRow).Find(What:="Start Date", LookIn:=xlValues)
        BottomRow = c.Row + 1    
    
        'Define and copy the range to sheet2
        ws1.Range("A" & i & ":A" & BottomRow).Copy
        ws2.Range("A" & PasteToRow).PasteSpecial Transpose:=True
        Application.CutCopyMode = False
    
            'Redefine the 'paste to' row
            PasteToRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
    
            'Redefine the top row of the next block of data
            i = BottomRow
    
    'Repeat the process
    Next i
    
    End Sub

推荐阅读