彰化一整天的論壇

 找回密碼
 立即註冊
12
返回列表 發新帖
樓主: luckysan

請問如何設定VBA自動判斷 [複製工作表某區間的資料]

[複製鏈接]
發表於 2020-12-26 19:29:48 | 顯示全部樓層
luckysan 發表於 2020-12-26 16:41
測試結果不行, 我只需要將還沒有銷貨資料的複製到空白帳冊而已,但您的程式中還會將已經銷貨的也帶到了空 ...

您好,
     您不是要把沒有銷售日期的複製到空白帳冊後再把原本的顯示清除.我這邊的執行結果如下.

excel20201226_01.jpg

1.要複製紅色框內的資料

excel20201226_02.jpg

2.貼到空白帳冊.

回復 支持 反對

使用道具 舉報

 樓主| 發表於 2020-12-26 21:01:08 | 顯示全部樓層
imingho 發表於 2020-12-26 19:29
您好,
     您不是要把沒有銷售日期的複製到空白帳冊後再把原本的顯示清除.我這邊的執行結果如下.

沒有錯,但其他工作表也要.... 我有用了您上面的
Dim wsCopy As Worksheet
    Dim wsDest As Worksheet
    Dim lCopyLastRow As Long
    Dim lDestLastRow As Long
   
    Dim i As Integer
   
    For i = 3 To Worksheets.Count

         Set wsCopy = Worksheets(i)
         Set wsDest = Workbooks("空白帳冊.xlsm").Worksheets(i)

套用到您最新設妥的下方:

'1. Find last used row in the copy range based on data in column D
    lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "D").End(xlUp).Row
    lCopyFirstRow = wsCopy.Cells(wsCopy.Rows.Count, "B").End(xlUp).Offset(1).Row
    '2. Find first blank row in the destination range based on data in column B
    'Offset property moves down 1 row
    lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1).Row
   
    '3. Copy & Paste Data 範圍" "須自行對照key
    wsCopy.Range("B" & lCopyFirstRow & ":X" & lCopyLastRow).Copy _
      wsDest.Range("B" & lDestLastRow)
   
    '4. Clear contents of existing data range 範圍" "須自行對照key
    wsCopy.Range("B" & lCopyFirstRow & ":X" & lCopyLastRow).ClearContents


但執行後,查看其他工作表,複製的便不正確了, 請問這個部分是要在修改哪邊才能適用每個工作表的情況
回復 支持 反對

使用道具 舉報

發表於 2020-12-26 22:45:00 | 顯示全部樓層
luckysan 發表於 2020-12-26 21:01
沒有錯,但其他工作表也要.... 我有用了您上面的
Dim wsCopy As Worksheet
    Dim wsDest As Worksheet

以後請上傳執行的畫面.檔案及程式碼.(避免像這次一樣,產生認知差距)
程式碼請用底下方法張貼.
http://discuz.bestdaylong.com/thread-30239-1-1.html
如何在discuz張貼程式碼

  1. Sub Copyandpastethendelete20201226()

  2.     Dim wsCopy As Worksheet
  3.     Dim wsDest As Worksheet
  4.     Dim lCopyLastRow As Long
  5.     Dim lDestLastRow As Long

  6.    
  7.     Dim i As Integer
  8.    
  9.     For i = 3 To Worksheets.Count

  10.          Set wsCopy = Worksheets(i)
  11.          Set wsDest = Workbooks("空白帳冊.xlsm").Worksheets(i)
  12.         
  13.         
  14.          '1. Find last used row in the copy range based on data in column D
  15.          lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "D").End(xlUp).Row
  16.          lCopyFirstRow = wsCopy.Cells(wsCopy.Rows.Count, "B").End(xlUp).Offset(1).Row
  17.          '2. Find first blank row in the destination range based on data in column B
  18.          'Offset property moves down 1 row
  19.          lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1).Row
  20.         
  21.          If lCopyLastRow > lCopyFirstRow Then  '有資料再複製清除
  22.              '3. Copy & Paste Data 範圍" "須自行對照key
  23.              wsCopy.Range("B" & lCopyFirstRow & ":X" & lCopyLastRow).Copy _
  24.                wsDest.Range("B" & lDestLastRow)
  25.             
  26.              '4. Clear contents of existing data range 範圍" "須自行對照key
  27.              wsCopy.Range("B" & lCopyFirstRow & ":X" & lCopyLastRow).ClearContents
  28.         End If
  29.    Next
  30. End Sub

複製代碼


回復 支持 反對

使用道具 舉報

 樓主| 發表於 2020-12-27 10:19:48 | 顯示全部樓層
本帖最後由 luckysan 於 2020-12-27 10:20 編輯
imingho 發表於 2020-12-26 22:45
以後請上傳執行的畫面.檔案及程式碼.(避免像這次一樣,產生認知差距)
程式碼請用底下方法張貼.
http://dis ...

謝謝imingho大大, 下次會注意代碼張貼方式
工作表頁籤執行ok
剩下以下在範例的活頁簿只有一列的無法被複製到空白帳冊,

1.


2.執行後,只有一列的資料沒有被複製過來空白帳冊
回復 支持 反對

使用道具 舉報

發表於 2020-12-27 11:49:35 | 顯示全部樓層
luckysan 發表於 2020-12-27 10:19
謝謝imingho大大, 下次會注意代碼張貼方式
工作表頁籤執行ok
剩下以下在範例的活頁簿只有一列的無法被複 ...

  1. Sub Copyandpastethendelete20201226()

  2.     Dim wsCopy As Worksheet
  3.     Dim wsDest As Worksheet
  4.     Dim lCopyLastRow As Long
  5.     Dim lDestLastRow As Long

  6.    
  7.     Dim i As Integer
  8.    
  9.     For i = 3 To Worksheets.Count

  10.          Set wsCopy = Worksheets(i)
  11.          Set wsDest = Workbooks("空白帳冊.xlsm").Worksheets(i)
  12.         
  13.         
  14.          '1. Find last used row in the copy range based on data in column D
  15.          lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "D").End(xlUp).Row
  16.          lCopyFirstRow = wsCopy.Cells(wsCopy.Rows.Count, "B").End(xlUp).Offset(1).Row
  17.          '2. Find first blank row in the destination range based on data in column B
  18.          'Offset property moves down 1 row
  19.          lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1).Row
  20.         
  21.          If lCopyLastRow >= lCopyFirstRow Then  '有資料再複製清除
  22.              '3. Copy & Paste Data 範圍" "須自行對照key
  23.              wsCopy.Range("B" & lCopyFirstRow & ":X" & lCopyLastRow).Copy _
  24.                wsDest.Range("B" & lDestLastRow)
  25.             
  26.              '4. Clear contents of existing data range 範圍" "須自行對照key
  27.              wsCopy.Range("B" & lCopyFirstRow & ":X" & lCopyLastRow).ClearContents
  28.         End If
  29.    Next
  30. End Sub
複製代碼
回復 支持 反對

使用道具 舉報

 樓主| 發表於 2020-12-28 09:26:19 | 顯示全部樓層

imingho大大,謝謝您,可以了,

最後一個需求是希望遇到標題列(只有$B6那一列是每個工作表的標題)
所複製的某工作表資料當中若是遇到頂端有空白列貼在$B7那一列的話,
則刪除"空白帳冊"中位於$B7的空白無資料列
其他若有依序複製資料中有空白列的部分則不需要刪除, 我截圖下方圖片給您參考:

1.例如下方這個客戶資料中,未銷貨的部分有留一個空白列



2.如果複製到空白帳冊的資料在標題列下方一列是空白列的話,希望可刪除該空白列
(綠色方框那列希望可以做到刪除)


但若是以下狀況則所複製到的紅色那列空白列是需要保留,希望綠色那列是要刪除的:

1.原範例某一客戶工作表的資料分布:


2.複製到空白帳冊後, 在標題列下方的綠色那列是空白無資料,希望可以刪除該列

回復 支持 反對

使用道具 舉報

發表於 2020-12-28 14:13:46 | 顯示全部樓層
本帖最後由 imingho 於 2020-12-28 14:15 編輯
luckysan 發表於 2020-12-28 09:26
imingho大大,謝謝您,可以了,

最後一個需求是希望遇到標題列(只有$B6那一列是每個工作表的標題)

  1. Sub Copyandpastethendelete20201228()

  2.     Dim wsCopy As Worksheet
  3.     Dim wsDest As Worksheet
  4.     Dim lCopyLastRow As Long
  5.     Dim lDestLastRow As Long

  6.    
  7.     Dim i As Integer
  8.    
  9.     For i = 3 To Worksheets.Count

  10.          Set wsCopy = Worksheets(i)
  11.          Set wsDest = Workbooks("空白帳冊.xlsm").Worksheets(i)
  12.         
  13.         
  14.          '1. Find last used row in the copy range based on data in column D
  15.          lCopyLastRow = wsCopy.Cells(wsCopy.Rows.Count, "D").End(xlUp).Row
  16.          lCopyFirstRow = wsCopy.Cells(wsCopy.Rows.Count, "B").End(xlUp).Offset(1).Row
  17.          '2. Find first blank row in the destination range based on data in column B
  18.          'Offset property moves down 1 row
  19.          lDestLastRow = wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1).Row
  20.         
  21.          If lCopyLastRow >= lCopyFirstRow Then  '有資料再複製清除
  22.              '3. Copy & Paste Data 範圍" "須自行對照key
  23.              wsCopy.Range("B" & lCopyFirstRow & ":X" & lCopyLastRow).Copy _
  24.                wsDest.Range("B" & lDestLastRow)
  25.                
  26.             If wsDest.Range("D7") = "" And lDestLastRow = 7 Then '空白且第一次第一列空白就刪除
  27.                wsDest.Range("D7").EntireRow.Delete
  28.             End If
  29.                
  30.             
  31.              '4. Clear contents of existing data range 範圍" "須自行對照key
  32.              wsCopy.Range("B" & lCopyFirstRow & ":X" & lCopyLastRow).ClearContents
  33.         End If
  34.    Next
  35. End Sub


複製代碼
回復 支持 反對

使用道具 舉報

 樓主| 發表於 2020-12-28 19:47:58 | 顯示全部樓層

謝謝imingho大大, 完全可以了

回復 支持 反對

使用道具 舉報

您需要登錄後才可以回帖 登錄 | 立即註冊

本版積分規則

 ㄚ母滴雞湯
 員林香純滴雞精

Archiver|手機版|小黑屋|彰化一整天的論壇(Excel,Office)

GMT+8, 2021-9-21 16:52 , Processed in 0.102745 second(s), 16 queries .

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回復 返回頂部 返回列表