Dinamik hücrelere sahip çalışma kitapları arasında verileri kopyalayın

Question

Verileri bir Excel elektronik tablosundan diğerine kopyalamaya çalışıyor (New_data'dan rapora).

New_data hesap tablosunda ikinci kez Sistem'i buluyorum (bu nedenle neden ilkinin altındaki aramaya başlıyorum N21) göründüğünde, altındaki tüm verileri b - k sütunlarından boş hücrelere ulaşana kadar kopyalamam gerekiyor. Yalnızca doldurulmuş hücreleri yakalamak için satır miktarını nasıl elde ederim?

Range("B584:K641") dinamik olması gerekiyor.

---

Sub CopyWorkbook()
 Range("N21").Select
    Cells.Find(What:="system", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    Range("B584:K641").Select
    Selection.Copy
    Application.WindowState = xlNormal
    Windows("report.xlsx").Activate
    Range("A2").Select
    ActiveSheet.Paste
    Windows("new_data.csv"). _
    Activate
End Sub

Answer 1

Lütfen sonraki kodu deneyin. Çok hızlı olmalı ('sistem' için nerede aranacağını doğru anladıysam, neyle başlayarak ...). Kod, "new_data.csv" nin csv çalışma kitabı adı olduğunu varsayar. Değilse, shCSVsayfayı tanımlarken gerçek adını kullanmanız gerekir :

Sub CopyWorkbook()
 Dim shR As Worksheet, shCSV As Worksheet, lastRow As Long, systCell As Range, arr

 Set shR = Workbooks("report.xlsx").ActiveSheet   'use here the sheet you need to paste
                                                  'it should be better to use the sheet name. 
                                                  'No need to have the respective sheet activated at the beginning
 Set shCSV = Workbooks("new_data.csv").Sheets(1)  'csv file has a single sheet, anyhow
 lastRow = shCSV.Range("B" & rows.count).End(xlUp).row

  Set systCell = shCSV.Range("B21:B" & lastRow).Find(What:="system", _
             After:=shCSV.Range("B21"), LookIn:=xlFormulas, LookAt _
             :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
                                                        False, SearchFormat:=False)
  If systCell Is Nothing Then MsgBox "No 'sytem' cell has been found...": Exit Sub
  arr = shCSV.Range(systCell, shCSV.Range("K" & lastRow)).Value
  shR.Range("A2").Resize(UBound(arr), UBound(arr, 2)).Value = arr
End Sub

Answer 2

Deneyin:

Sub test()

Dim LR As Long
Dim Ini As Long
LR = Range("B" & Rows.Count).End(xlUp).Row 'last non empty row in column B

Ini = Application.WorksheetFunction.Match("system", Range("N21:N" & LR), 0) + 20 'position of system after n21

Range("B" & Ini & ":K" & LR).Copy

'''rest of your code to paste
End Sub

Bu kodun systemyalnızca N sütunundaki kelimeyi aradığını unutmayın. Başka bir yerdeyse, MATCH işlevini uyarlamanız gerekir.

Answer 3

Filtrelenen aralığa eşit bir aralık belirledim ve B sütunundaki ilk boş hücreye kadar boş hücre olmadığını saymak için bir döngü başlattım.

    Sub CopyWorkbook()
        ThisWorkbook.Sheets("new_data").Activate
        Range("N21").Select
        Dim rng As Range
        Set rng = Cells.Find(What:="system", After:=ActiveCell, _
        LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ 
        MatchCase:=False, _
        SearchFormat:=False)
        Dim i As Double
        i = rng.Row
        Do Until ThisWorkbook.Sheets("new_data").Range("B" & i) = vbNullString
            i = i + 1
        Loop
        i = i - 1
        Range("B" & rng.Row & ":K" & i).Select
        Selection.Copy
        Application.WindowState = xlNormal
        Windows("report.xlsx").Activate
        Range("A2").Select
        ActiveSheet.Paste
        Windows("new_data.csv").Activate
    End Sub

Cevap bulmada yardımcı olan bir Yığın Taşması sorusu buldum. Hücre adresini bulun