Note: The other languages of the website are Google-translated. Back to English

วิธีย้ายทั้งแถวไปยังแผ่นงานอื่นตามค่าเซลล์ใน Excel

สำหรับการย้ายทั้งแถวไปยังแผ่นงานอื่นตามค่าของเซลล์บทความนี้จะช่วยคุณได้

ย้ายทั้งแถวไปยังแผ่นงานอื่นตามค่าเซลล์ด้วยรหัส VBA
ย้ายทั้งแถวไปยังแผ่นงานอื่นตามค่าของเซลล์ด้วย Kutools for Excel


ย้ายทั้งแถวไปยังแผ่นงานอื่นตามค่าเซลล์ด้วยรหัส VBA

ตามที่แสดงภาพหน้าจอด้านล่างคุณต้องย้ายทั้งแถวจาก Sheet1 ไปยัง Sheet2 หากมีคำเฉพาะ "Done" อยู่ในคอลัมน์ C คุณสามารถลองใช้รหัส VBA ต่อไปนี้

1 กด อื่น ๆ+ F11 พร้อมกันเพื่อเปิดไฟล์ Microsoft Visual Basic สำหรับแอปพลิเคชัน หน้าต่าง

2. ในหน้าต่าง Microsoft Visual Basic for Applications คลิก สิ่งที่ใส่เข้าไป > โมดูล. จากนั้นคัดลอกและวางโค้ด VBA ด้านล่างลงในหน้าต่าง

VBA code 1: Move entire row to another sheet based on cell value

Sub Cheezy()
'Updated by Kutools for Excel 2017/8/28
    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long
    I = Worksheets("Sheet1").UsedRange.Rows.Count
    J = Worksheets("Sheet2").UsedRange.Rows.Count
    If J = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("Sheet1").Range("C1:C" & I)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.Count
        If CStr(xRg(K).Value) = "Done" Then
            xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
            xRg(K).EntireRow.Delete
            If CStr(xRg(K).Value) = "Done" Then
                K = K - 1
            End If
            J = J + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub

หมายเหตุ: ในรหัส Sheet1 คือแผ่นงานมีแถวที่คุณต้องการย้าย และ Sheet2 คือแผ่นงานปลายทางที่คุณจะค้นหาแถว “ค: ค” คือคอลัมน์มีค่าที่แน่นอนและคำว่า“เสร็จสิ้น” คือค่าบางอย่างที่คุณจะย้ายแถวตาม โปรดเปลี่ยนตามความต้องการของคุณ

3 กด F5 เพื่อรันโค้ดจากนั้นแถวที่ตรงตามเกณฑ์ใน Sheet1 จะถูกย้ายไปที่ Sheet2 ทันที

หมายเหตุ: โค้ด VBA ด้านบนจะลบแถวจากข้อมูลต้นฉบับหลังจากย้ายไปยังแผ่นงานที่ระบุ หากคุณต้องการคัดลอกเฉพาะแถวตามค่าของเซลล์แทนที่จะลบออก กรุณาใช้รหัส VBA ด้านล่าง 2

VBA code 2: Copy entire row to another sheet based on cell value

Sub MoveRowBasedOnCellValue()
'Updated by Extendoffice 2017/11/10
    Dim xRg As Range
    Dim xCell As Range
    Dim I As Long
    Dim J As Long
    Dim K As Long
    I = Worksheets("Sheet1").UsedRange.Rows.Count
    J = Worksheets("Sheet2").UsedRange.Rows.Count
    If J = 1 Then
    If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then J = 0
    End If
    Set xRg = Worksheets("Sheet1").Range("C1:C" & I)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.Count
        If CStr(xRg(K).Value) = "Done" Then
            xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1)
            J = J + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub

ย้ายทั้งแถวไปยังแผ่นงานอื่นตามค่าของเซลล์ด้วย Kutools for Excel

หากคุณเป็นมือใหม่ในรหัส VBA ที่นี่ฉันขอแนะนำ เลือกเซลล์เฉพาะ ประโยชน์ของ Kutools สำหรับ Excel. ด้วยยูทิลิตี้นี้คุณสามารถเลือกแถวทั้งหมดตามค่าของเซลล์บางค่าหรือค่าของเซลล์ที่แตกต่างกันในแผ่นงานและคัดลอกแถวที่เลือกไปยังแผ่นงานปลายทางได้ตามที่คุณต้องการ กรุณาดำเนินการดังนี้

ก่อนที่จะใช้ Kutools สำหรับ Excelโปรด ดาวน์โหลดและติดตั้งในตอนแรก.

1. เลือกรายการคอลัมน์ที่มีค่าเซลล์ที่คุณจะย้ายแถวตามจากนั้นคลิก Kutools > เลือก > เลือกเซลล์เฉพาะ. ดูภาพหน้าจอ:

2. ในการเปิด เลือกเซลล์เฉพาะ ให้เลือก ทั้งแถว ใน ประเภทการเลือก เลือก เท่ากับ ใน ประเภทเฉพาะ รายการแบบหล่นลงป้อนค่าเซลล์ลงในกล่องข้อความแล้วคลิกไฟล์ OK ปุ่ม

อื่น เลือกเซลล์เฉพาะ กล่องโต้ตอบจะปรากฏขึ้นเพื่อแสดงจำนวนแถวที่เลือกและในขณะเดียวกันแถวทั้งหมดมีค่าที่ระบุในคอลัมน์ที่เลือกได้ถูกเลือก ดูภาพหน้าจอ:

3 กด Ctrl + C เพื่อคัดลอกแถวที่เลือกแล้ววางลงในแผ่นงานปลายทางที่คุณต้องการ

หมายเหตุ: ถ้าคุณต้องการย้ายแถวไปยังแผ่นงานอื่นโดยยึดตามค่าเซลล์ที่ต่างกันสองค่า ตัวอย่างเช่นย้ายแถวตามค่าของเซลล์ "เสร็จสิ้น" หรือ "กำลังประมวลผล" คุณสามารถเปิดใช้งานไฟล์ Or เงื่อนไขใน เลือกเซลล์เฉพาะ กล่องโต้ตอบด้านล่างภาพหน้าจอที่แสดง:

  หากคุณต้องการทดลองใช้ฟรี (30วัน) ของโปรแกรมอรรถประโยชน์นี้ กรุณาคลิกเพื่อดาวน์โหลดแล้วไปใช้การดำเนินการตามขั้นตอนข้างต้น


บทความที่เกี่ยวข้อง:


เครื่องมือเพิ่มประสิทธิภาพการทำงานในสำนักงานที่ดีที่สุด

Kutools สำหรับ Excel แก้ปัญหาส่วนใหญ่ของคุณและเพิ่มผลผลิตของคุณได้ถึง 80%

  • นำมาใช้ใหม่: ใส่อย่างรวดเร็ว สูตรที่ซับซ้อนแผนภูมิ และสิ่งที่คุณเคยใช้มาก่อน เข้ารหัสเซลล์ ด้วยรหัสผ่าน; สร้างรายชื่อผู้รับจดหมาย และส่งอีเมล ...
  • ซุปเปอร์ฟอร์มูล่าบาร์ (แก้ไขข้อความและสูตรหลายบรรทัดได้อย่างง่ายดาย); การอ่านเค้าโครง (อ่านและแก้ไขเซลล์จำนวนมากได้อย่างง่ายดาย); วางลงในช่วงที่กรองแล้ว...
  • ผสานเซลล์ / แถว / คอลัมน์ โดยไม่สูญเสียข้อมูล แยกเนื้อหาของเซลล์ รวมแถว / คอลัมน์ที่ซ้ำกัน... ป้องกันเซลล์ซ้ำ; เปรียบเทียบช่วง...
  • เลือกซ้ำหรือไม่ซ้ำ แถว; เลือกแถวว่าง (เซลล์ทั้งหมดว่างเปล่า); Super Find และ Fuzzy Find ในสมุดงานจำนวนมาก สุ่มเลือก ...
  • สำเนาถูกต้อง หลายเซลล์โดยไม่เปลี่ยนการอ้างอิงสูตร สร้างการอ้างอิงอัตโนมัติ ถึงหลายแผ่น ใส่สัญลักษณ์แสดงหัวข้อย่อย, กล่องกาเครื่องหมายและอื่น ๆ ...
  • แยกข้อความ, เพิ่มข้อความ, ลบตามตำแหน่ง, ลบ Space; สร้างและพิมพ์ผลรวมย่อยของเพจ แปลงระหว่างเนื้อหาของเซลล์และความคิดเห็น...
  • ซุปเปอร์ฟิลเตอร์ (บันทึกและใช้โครงร่างตัวกรองกับแผ่นงานอื่น ๆ ); การเรียงลำดับขั้นสูง ตามเดือน / สัปดาห์ / วันความถี่และอื่น ๆ ตัวกรองพิเศษ โดยตัวหนาตัวเอียง ...
  • รวมสมุดงานและแผ่นงาน; ผสานตารางตามคอลัมน์สำคัญ แยกข้อมูลออกเป็นหลายแผ่น; Batch แปลง xls, xlsx และ PDF...
  • คุณสมบัติที่ทรงพลังมากกว่า 300 รายการ. รองรับ Office/Excel 2007-2021 และ 365 รองรับทุกภาษา ง่ายต่อการปรับใช้ในองค์กรหรือองค์กรของคุณ คุณสมบัติเต็มรูปแบบ ทดลองใช้ฟรี 30 วัน รับประกันคืนเงินภายใน 60 วัน
kte แท็บ 201905

แท็บ Office นำอินเทอร์เฟซแบบแท็บมาที่ Office และทำให้งานของคุณง่ายขึ้นมาก

  • เปิดใช้งานการแก้ไขและอ่านแบบแท็บใน Word, Excel, PowerPoint, ผู้จัดพิมพ์, Access, Visio และโครงการ
  • เปิดและสร้างเอกสารหลายรายการในแท็บใหม่ของหน้าต่างเดียวกันแทนที่จะเป็นในหน้าต่างใหม่
  • เพิ่มประสิทธิภาพการทำงานของคุณ 50% และลดการคลิกเมาส์หลายร้อยครั้งให้คุณทุกวัน!
ด้านล่าง officetab
จัดเรียงความคิดเห็นโดย
ความคิดเห็น (299)
ยังไม่มีการให้คะแนน เป็นคนแรกที่ให้คะแนน!
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดี ฉันพบว่าคู่มือนี้มีประโยชน์มากกว่าคนอื่น ๆ ที่ฉันเคยเห็น ขอขอบคุณ! ปัญหาที่ฉันมีคือถ้าฉันเปลี่ยนค่าที่ต้องการเป็น 'ปิด' ฉันต้องเรียกใช้ F5 เพื่อย้ายแถว ฉันต้องการให้มันย้ายโดยอัตโนมัติ ฉันยังใหม่กับ Excel ดังนั้นความช่วยเหลือของคุณจึงได้รับการชื่นชมอย่างมาก Sub Cheezy() Dim xRg As Range Dim xCell As Range Dim I As Long Dim J As Long I = Worksheets("ECR Incident Tracker") .UsedRange.Rows.Count J = Worksheets("Resolved Issues") ).UsedRange.Rows. นับถ้า J = 1 แล้วถ้า Application.WorksheetFunction.CountA(เวิร์กชีต ("ปัญหาที่ได้รับการแก้ไข") = 0 จากนั้น J = 0 สิ้นสุดหากตั้งค่า xRg = แผ่นงาน ("ECR Incident Tracker") ช่วง ("B1:B" & I) เกี่ยวกับข้อผิดพลาด ดำเนินการต่อแอปพลิเคชันถัดไป ScreenUpdating = False สำหรับแต่ละ xCell ใน xRg ถ้า CStr(xCell.Value) = "ปิด" จากนั้น xCell.EntireRow.Copy Destination:=Worksheets("Resolved Issues")).Range("A" & J + 1) xCell.EntireRow.Delete J = J + 1 End ถ้า Next Application.ScreenUpdating = True End Sub
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดี ฉันกำลังพยายามย้ายเซลล์โดยอัตโนมัติโดยไม่ต้องเปิดโมดูลและกด F5 เช่นกัน คุณเคยแก้ไขคำถามนี้หรือไม่? ขอบคุณล่วงหน้า!
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
Crystal ให้ข้อมูลเกี่ยวกับวิธีการทำสิ่งนั้นในวันนี้ - ดูที่หน้าหนึ่งของหัวข้อนี้เพื่อดูคำตอบของเธอ มันจะย้ายแถวที่มีวันที่ของวันนี้ในคอลัมน์ (L ในกรณีของฉัน) ไปยังแผ่นงานอื่นโดยอัตโนมัติ
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
ฉันกำลังเรียกใช้รหัสนี้และกำลังพยายามย้ายแถวตามวันที่ของวันนี้ที่ปรากฏในคอลัมน์ I - ฉันเปลี่ยน Range("B1:B" & I) เป็นอ่าน Range(I1:I" & I) แล้ว ฉันเปลี่ยนไปแล้ว " เสร็จสิ้น" ในตัวอย่างของคุณเป็น Date อย่างไรก็ตาม เมื่อวันที่ของวันนี้ปรากฏที่ใดก็ได้ในแถว ไม่ใช่แค่ในคอลัมน์ I ตามที่ต้องการ แถวจะย้ายไปที่เวิร์กชีตสำรอง ความคิดใด ๆ ว่าทำไมสิ่งนี้จึงเกิดขึ้น และฉันจะย้ายแถวได้อย่างไร เฉพาะเมื่อวันที่ของวันนี้อยู่ในคอลัมน์ I ไม่ว่าวันที่ของวันนี้จะปรากฏในคอลัมน์อื่นหรือไม่
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
ถ้าฉันต้องการมีหลายค่าและหลายแผ่นเพื่อย้ายแถวของฉันไป ฉันจะต้องเขียนโค้ดทั้งหมดอีกครั้งด้วยค่าอื่นสำหรับเซลล์นั้นหรือไม่ ความหมาย ถ้าฉันใส่ NA ลงในเซลล์เดียว มันจะไปที่แผ่น Na และถ้าฉันใส่ W# มันจะไปที่แผ่นตัวเลขที่ไม่ถูกต้อง เป็นต้น
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดี สิ่งนี้มีประโยชน์มาก มีวิธีการทำเช่นนี้โดยไม่ต้องย้ายแถวของข้อมูลไปยังแผ่นงานที่สอง แต่ให้คัดลอกหรือไม่ ดังนั้นข้อมูลจะยังคงอยู่ในทั้งสองแผ่นงาน?
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดี รหัสมีประโยชน์มาก แต่แทนที่จะคัดลอกทั้งแถว ฉันต้องการเลือกแถวบางแถวเพื่อย้ายไปยังแผ่นงานถัดไป ฉันจะกำหนดช่วงแทนที่จะเป็นทั้งแถวได้อย่างไร Sub Cheezy() Dim xRg As Range Dim xCell As Range Dim I As Long Dim J As Long I = Worksheets("Sheet1").UsedRange.Rows.Count J = Worksheets(" Sheet2") UsedRange.Rows.Count ถ้า J = 1 ถ้า Application.WorksheetFunction.CountA(Worksheets("Sheet2") .UsedRange) = 0 แล้ว J = 0 End ถ้า Set xRg = Worksheets ("Sheet1").Range( "C1:C" & I) เมื่อเกิดข้อผิดพลาด Resume Next Application.ScreenUpdating = False สำหรับแต่ละ xCell In xRg ถ้า CStr(xCell.Value) = "เสร็จสิ้น" จากนั้น xCellทั้งแถว.Copy Destination:=Worksheets("Sheet2")).Range("A" & J + 1) J = J + 1 End ถ้า Next Application.ScreenUpdating = True End Sub
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
รหัสจะเป็นอย่างไรหากฉันต้องการคัดลอกแถว (เซลล์ที่ระบุ) ลงในชีตอื่นไปยังเซลล์ที่ระบุ แต่ยังขึ้นอยู่กับค่า ตัวอย่าง: สตริงรูปภาพผลิตภัณฑ์สี เครื่องปั่นสีขาว 2 เครื่องปั่นสีขาว 2 เครื่องคั้นน้ำผลไม้สีดำ 3 เครื่องคั้นน้ำผลไม้สีดำ 3 ทีวีสีแดง 1 redtv1 เตารีดสีเขียว 4 เตารีดสีเขียว 4 ฉันต้องการคัดลอกสตริงไปยังแผ่นงานอื่น แต่ตัวเลขในคอลัมน์รูปภาพบอกว่าควรคัดลอกกี่ครั้ง (ในกรณีนี้ สตริงเครื่องปั่น ควรคัดลอกเป็น 2 แถว
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดี รหัสที่ดีมาก ทำงานได้ดีมาก วิธีเปลี่ยนรหัสนี้เพื่อย้ายแถวจากตารางหนึ่งไปยังอีกตารางหนึ่ง แทนที่จะเป็นแผ่นงานหนึ่งไปยังอีกแผ่นหนึ่ง ขอบคุณมาก !
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดี ฉันกำลังพยายามใช้รหัส แต่ได้รับข้อผิดพลาดทางไวยากรณ์ใน Dim xCell As Range คุณช่วยได้ไหม
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
Sub Cheezy() Dim xRg As Range Dim xCell As Range Dim I As Long Dim J As Long I = Worksheets("Sheet1")).UsedRange.Rows.Count J = Worksheets("Sheet2")).UsedRange.Rows.Count if J = 1 แล้วถ้า Application.WorksheetFunction.CountA(Worksheets("Sheet2")).UsedRange) = 0 แล้ว J = 0 End ถ้า Set xRg = Worksheets("Sheet1").Range("C1:C" & I) ในข้อผิดพลาด Resume Next Application.ScreenUpdating = False สำหรับแต่ละ xCell In xRg ถ้า CStr(xCell.Value) = "เสร็จสิ้น" จากนั้น xCell.EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & J + 1) xCell WholeRow.Delete J = J + 1 End ถ้า Next Application.ScreenUpdating = True End Sub จะเพิ่มแผ่นงานที่สองเพื่อให้แถวย้ายไปยังชีต 2 ได้อย่างไร
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
ฉันควรป้อนข้อมูลอะไรหากต้องการรวมวันที่ใด ๆ เป็นค่าของฉัน ดังนั้นแถวจะอยู่บนแผ่นที่ 1 หากไม่มีวันที่และย้ายไปที่แผ่นที่ 2 หากมี
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
[quote] สวัสดี สิ่งนี้มีประโยชน์มาก มีวิธีการทำเช่นนี้โดยไม่ต้องย้ายแถวของข้อมูลไปยังแผ่นงานที่สอง แต่ให้คัดลอกหรือไม่ ดังนั้นข้อมูลจะยังคงอยู่ในทั้งสองแผ่นงาน?โดย Maddie[/quote] ใครก็ได้ช่วยแก้ที
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
ลบ "xCell.EntireRow.Delete" นี้ออกจากโค้ด
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
เมื่อฉันลบโค้ดบรรทัดนั้นและเรียกใช้แมโครอีกครั้ง Excel จะหยุดทำงาน ทำไมและต้องแก้ไขอย่างไร?? ฉันต้องการให้ข้อมูลอยู่ในเวิร์กชีตทั้งสองและไม่ถูกลบออกจากต้นฉบับ TIA
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
มีคำตอบสำหรับเรื่องนี้หรือไม่? ของฉันค้างเช่นกัน ฉันต้องการคัดลอกแต่ไม่ลบแถว
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
ขอให้เป็นวันที่ดี,
โค้ด VBA ด้านล่างสามารถช่วยให้คุณคัดลอกเฉพาะแถวแทนที่จะลบออก

ย่อย Cheezy()
Dim xRg เป็นช่วง
Dim xCell เป็นช่วง
หรี่ฉันนาน
Dim J ตราบ
หรี่ K ตราบ
I = แผ่นงาน("Sheet1").UsedRange.Rows.Count
J = แผ่นงาน ("Sheet2") .UsedRange.Rows.Count
ถ้า J = 1 แล้ว
ถ้า Application.WorksheetFunction.CountA(Worksheets("Sheet2")).UsedRange) = 0 แล้ว J = 0
End If
ตั้งค่า xRg = แผ่นงาน("Sheet1")).ช่วง("C1:C" & I)
เกี่ยวกับข้อผิดพลาดต่อไป
Application.ScreenUpdating = เท็จ
สำหรับ K = 1 ถึง xRg.Count
ถ้า CStr(xRg(K).Value) = "เสร็จสิ้น" แล้ว
xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2")).Range("A" & J + 1)
เจ = เจ + 1
End If
ต่อไป
Application.ScreenUpdating = จริง
ย่อยสิ้นสุด
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดี ฉันกำลังมองหาความแตกต่างในเรื่องนี้ ฉันต้องการให้สคริปต์ทำงานอย่างต่อเนื่อง หรือล้มเหลวเมื่อใดก็ตามที่ค่าในฟิลด์เฉพาะนั้นเปลี่ยนแปลง โค้ดใช้งานได้ แต่ต้องเรียกใช้โดยอิสระ ฉันต้องการให้มันเป็นไปโดยอัตโนมัติ ใครสามารถช่วย?

ในทางกลับกัน หากฉันต้องการให้คัดลอกเฉพาะเซลล์ในช่วงที่กำหนด จะสำเร็จได้อย่างไร
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
เรียน คุณร็อบ

หากคุณต้องการให้สคริปต์ทำงานโดยอัตโนมัติเมื่อมีการเปลี่ยนแปลงเซลล์ในฟิลด์นั้น โค้ด VBA ด้านล่างสามารถช่วยคุณได้ โปรดคลิกขวาที่แผ่นงานปัจจุบัน (แผ่นงานที่มีแถวที่คุณจะย้ายโดยอัตโนมัติ) จากนั้นเลือก ดูรหัส จากเมนูบริบท จากนั้นคัดลอกและวางสคริปต์ VBA ด้านล่างลงในหน้าต่างรหัส

Worksheet_Change ย่อยส่วนตัว (เป้าหมายเป็นช่วง ByVal)

Dim xCell เป็นช่วง

หรี่ฉันนาน
เกี่ยวกับข้อผิดพลาดต่อไป

Application.ScreenUpdating = เท็จ

ตั้งค่า xCell = Target(1)
ถ้า xCell.Value = "เสร็จสิ้น" แล้ว
I = แผ่นงาน("Sheet2").UsedRange.Rows.Count
ถ้าฉัน = 1 แล้ว

ถ้า Application.WorksheetFunction.CountA(Worksheets("Sheet2")).UsedRange) = 0 แล้ว I = 0

End If

แผ่นงาน xCell.EntireRow.Copy("Sheet2")).Range("A" & I + 1)

xCell.EntireRow.Delete
End If

Application.ScreenUpdating = จริง

ย่อยสิ้นสุด


สำหรับคำถามที่สองของคุณ คุณหมายถึงแค่คัดลอกหลายเซลล์แทนที่จะคัดลอกทั้งแถวใช่หรือไม่ หรือคุณกรุณาให้ภาพหน้าจอของคำถามของคุณ? ขอขอบคุณ!

ขอแสดงความนับถือ Crystal
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
คริสตัล


ความช่วยเหลือของคุณมีความจำเป็นมากกว่านั้น :)



เราจะเพิ่ม crtieria อื่นได้อย่างไร ตัวอย่างเช่น ฉันต้องการโอนเสร็จสมบูรณ์ ข้างเสร็จสิ้น:


Worksheet_Change ย่อยส่วนตัว (เป้าหมายเป็นช่วง ByVal)

Dim xCell เป็นช่วง

หรี่ฉันนาน
เกี่ยวกับข้อผิดพลาดต่อไป

Application.ScreenUpdating = เท็จ

ตั้งค่า xCell = Target(1)
ถ้า xCell.Value = "เสร็จสิ้น" แล้ว
I = แผ่นงาน("Sheet2").UsedRange.Rows.Count
ถ้าฉัน = 1 แล้ว

ถ้า Application.WorksheetFunction.CountA(Worksheets("Sheet2")).UsedRange) = 0 แล้ว I = 0

End If

แผ่นงาน xCell.EntireRow.Copy("Sheet2")).Range("A" & I + 1)

xCell.EntireRow.Delete
End If

Application.ScreenUpdating = จริง

ย่อยสิ้นสุด
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดีคริสตัล
นี่เป็นข้อมูลที่มีประโยชน์ที่สุดที่ฉันพบบนเว็บ และมาโครนี้ทำในสิ่งที่ฉันต้องการ แต่ฉันกำลังย้ายแถวจากตารางหนึ่งไปยังอีกตารางหนึ่ง - และด้วยมาโครนี้ ข้อมูลจะย้ายจากบรรทัดว่างแรกนอกตาราง ไม่ใช่บรรทัดถัดไปในตารางใช่หรือไม่ คุณช่วยได้ไหม
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
ฉันกำลังเรียกใช้รหัสนี้และกำลังพยายามย้ายแถวตามวันที่ของวันนี้ที่ปรากฏในคอลัมน์ I - ฉันเปลี่ยน Range("B1:B" & I) เป็นอ่าน Range(I1:I" & I) แล้ว ฉันเปลี่ยนไปแล้ว " เสร็จสิ้น" ในตัวอย่างของคุณเป็น Date อย่างไรก็ตาม เมื่อวันที่ของวันนี้ปรากฏที่ใดก็ได้ในแถว ไม่ใช่แค่ในคอลัมน์ I ตามที่ต้องการ แถวจะย้ายไปที่เวิร์กชีตสำรอง ความคิดใด ๆ ว่าทำไมสิ่งนี้จึงเกิดขึ้น และฉันจะย้ายแถวได้อย่างไร เฉพาะเมื่อวันที่ของวันนี้อยู่ในคอลัมน์ I ไม่ว่าวันที่ของวันนี้จะปรากฏในคอลัมน์อื่นหรือไม่
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
เรียนเดวิด

รหัสทำงานได้ดีสำหรับฉันหลังจากเปลี่ยนช่วงและค่าตัวแปรเป็นวันที่ รูปแบบวันที่ในโค้ดของคุณต้องตรงกับรูปแบบวันที่ที่คุณใช้ในเวิร์กชีต หรือสะดวกสำหรับคุณที่จะแนบแผ่นงานของคุณ?
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดีคริสตัล


ฉันไม่ชัดเจนว่าคุณหมายถึงอะไรเมื่อคุณพูดว่ารูปแบบวันที่ของโค้ดและสเปรดชีตต้องตรงกัน - ฉันไม่ใช่ผู้เชี่ยวชาญ VB แต่เป็นระดับสามเณรมากกว่า ในสเปรดชีตของฉัน ฉันป้อนวันที่ของวันนี้ในคอลัมน์ F เป็นวันที่เข้าสู่แถวในรูปแบบ ctrl + : ฉันป้อนวันหมดอายุในคอลัมน์ "ฉัน" ในรูปแบบ วว/ดด/ปปปป อย่างไรก็ตาม สิ่งนี้ทำให้เกิดปัญหาเมื่อสร้างรายการแถวใหม่และป้อนวันที่ของวันนี้ในคอลัมน์ F เพราะทันทีที่ป้อน แถวจะถูกย้ายไปยังแผ่นงานใหม่ นอกจากนี้ รหัสเพิ่มเติมที่จะเรียกใช้ทุกครั้งที่เปิดสมุดงานจะไม่ปรากฏขึ้น ให้วิ่งไปโดยที่ฉันไม่ต้องบังคับ ขออภัยสำหรับปัญหาที่อาจเล็กน้อยสำหรับคุณ แต่เราไม่สามารถรับฟังปัญหาเหล่านี้ได้ ความช่วยเหลือใด ๆ ที่จะได้รับการชื่นชม
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
เรียนเดวิด

ฉันได้ลองตามที่คุณกล่าวไว้ข้างต้นแล้ว แต่ปริมาณปัญหาไม่ปรากฏในกรณีของฉัน คุณสามารถระบุเวอร์ชัน Excel ของคุณได้หรือไม่ ฉันต้องการข้อมูลเพิ่มเติมเพื่อช่วยแก้ปัญหานี้ ขอโทษที่รบกวนคุณอีกครั้ง

ขอแสดงความนับถือ Crystal
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
คริสตัล นี่คือใบงานที่เกี่ยวข้อง คุณจะเห็นในโค้ดที่คัดลอกมาซึ่งฉันกำลังค้นหา "จนถึง " วันที่ของวันนี้ในคอลัมน์ L และหาก "สูงสุด" และรวมถึงวันที่ของวันนี้อยู่ในคอลัมน์นั้น ฉันต้องการย้ายแถวที่มีวันที่นั้นไปยังแผ่นงานใหม่ ปัจจุบัน เมื่อฉันป้อนวันที่ของวันนี้ที่ใดก็ได้ในแถว (เช่น คอลัมน์ F หากมีการชักชวนในวันนี้) ระบบจะย้ายทั้งแถวไปยังสเปรดชีตที่เก็บถาวรโดยอัตโนมัติ ฉันมักจะป้อนวันที่ของวันนี้โดยใช้การรวมกัน ctrl + : โดยปกติในคอลัมน์ F
นอกจากนี้ ฉันต้องการให้การย้ายนี้เกิดขึ้นเมื่อฉันเปิดสมุดงาน ตอนนี้ต้องไปโชว์โค้ดแล้วกด F5 คำแนะนำเกี่ยวกับวิธีการทำเช่นนั้นยินดี
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
น่าเสียดายที่เวิร์กบุ๊กที่เปิดใช้งานมาโครของฉันจะไม่อัปโหลดตามที่แจ้งว่ารูปแบบไม่รองรับ เหล่านี้อยู่ใน Excel 2016
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
เรียนเดวิด

รหัส VBA ต่อไปนี้สามารถช่วยให้คุณบรรลุเป้าหมายได้

สมุดงานย่อยส่วนตัว_Open()
Dim xRg เป็นช่วง
Dim xCell เป็นช่วง
หรี่ฉันนาน
Dim J ตราบ
I = แผ่นงาน ("โอกาสปัจจุบันของ OASIS") ใช้ช่วง.Rows.Count
J = แผ่นงาน ("โอกาสเก็บถาวร OASIS") ใช้ช่วง.Rows.Count
ถ้า J = 1 แล้ว
ถ้า Application.WorksheetFunction.CountA(Worksheets("ARCHIVED OASIS OPPORTUNITIES") UsedRange) = 0 แล้ว J = 0
End If
ตั้งค่า xRg = แผ่นงาน ("โอกาสปัจจุบันของ OASIS") ช่วง ("L1:L" & I)
เกี่ยวกับข้อผิดพลาดต่อไป
Application.ScreenUpdating = เท็จ
สำหรับแต่ละ xCell ใน xRg
ถ้า CStr(xCell.Value) = วันที่ แล้ว
xCell.EntireRow.Copy Destination:=Worksheets("ARCHIVED OASIS OPPORTUNITIES") ช่วง("A" & J + 1)
xCell.EntireRow.Delete
เจ = เจ + 1
End If
ต่อไป
ย่อยสิ้นสุด

หมายเหตุ:
1. คุณต้องใส่สคริปต์ VBA ลงในหน้าต่างรหัส ThisWorkbook
2. สมุดงานของคุณต้องบันทึกเป็นสมุดงาน Excel Macro-Enabled

หลังจากการดำเนินการข้างต้น ทุกครั้งที่คุณเปิดเวิร์กบุ๊ก แถวทั้งแถวจะถูกย้ายไปยังเวิร์กชีต ARCHIVED ถ้าเซลล์ในคอลัมน์ L ถึงวันที่ของวันนี้

ขอแสดงความนับถือ คริสตัล
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
ขอบคุณคริสตัล
วิธีนี้ใช้ได้ผลดีหากถึงวันที่ของวันนี้ในคอลัมน์ L มีวิธีใดบ้างที่จะรวมวันที่ของวันนี้ในคอลัมน์ L ด้วย เพื่อว่าหากฉันไม่ตรวจสอบเวิร์กบุ๊กเป็นเวลาหลายวัน ระบบจะรวมวันที่ก่อนหน้าก่อนหน้านั้นโดยอัตโนมัติ วันนี้? ขอบคุณมากสำหรับความช่วยเหลือของคุณ.
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
เรียนเดวิด

ขออภัย ฉันไม่แน่ใจว่าฉันได้รับคำถามของคุณ ถ้าเป็นเช่นนั้น แถวทั้งหมดจะถูกย้ายตราบเท่าที่วันที่ก่อนหน้าปรากฏในคอลัมน์ L?
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดีคริสตัล

ถ้าฉันไม่เปิดเวิร์กชีตเป็นเวลาสองสามวันและวันที่ที่ป้อนในคอลัมน์ L ได้ผ่านไปแล้ว เช่น วันที่ในเซลล์ในคอลัมน์ L คือ 11 กันยายน 2017 แต่อย่าเปิดเวิร์กชีตของฉันจนถึงวันที่ 13 กันยายน ฉันจะทำ เช่นเดียวกับรายการทั้งหมดในคอลัมน์ L ที่จะตรวจสอบทุกวันจนถึงวันนี้ จากนั้นย้ายแถวที่เกี่ยวข้องไปยังแผ่นงานใหม่ ขณะนี้ด้วยรหัสที่คุณให้ไว้อย่างสุภาพ เฉพาะแถวที่มีวันที่ปัจจุบันในคอลัมน์ L เท่านั้นที่จะถูกย้ายไปยังแผ่นงานใหม่ โดยเหลือไว้ข้างหลังที่มีวันที่ก่อนหน้าในคอลัมน์ L ซึ่งขณะนี้ฉันกำลังย้ายด้วยตนเองไปยังแผ่นงานใหม่ ขอบคุณสำหรับความช่วยเหลือของคุณ.
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
เรียนเดวิด



ฉันเข้าใจประเด็นของคุณ โปรดลองใช้สคริปต์ VBA ด้านล่าง เมื่อเปิดสมุดงาน แถวทั้งหมดที่มีวันที่ถึงวันที่ของวันนี้ในคอลัมน์ L จะถูกย้ายไปยังแผ่นงานใหม่ที่ระบุ



สมุดงานย่อยส่วนตัว_Open()
Dim xRg เป็นช่วง
Dim xRgRtn เป็นช่วง
Dim xCell เป็นช่วง
Dim xLastRow ตราบใดที่
หรี่ฉันนาน
Dim J ตราบ
เกี่ยวกับข้อผิดพลาดต่อไป
xLastRow = แผ่นงาน ("โอกาสปัจจุบันของ OASIS") UsedRange.Rows.Count
ถ้า xLastRow < 1 จากนั้นออกจาก Sub
J = แผ่นงาน ("โอกาสเก็บถาวร OASIS") ใช้ช่วง.Rows.Count
ถ้า J = 1 แล้ว
ถ้า Application.WorksheetFunction.CountA(Worksheets("ARCHIVED OASIS OPPORTUNITIES") UsedRange) = 0 แล้ว J = 0
End If
ตั้งค่า xRg = แผ่นงาน ("โอกาสปัจจุบันของ OASIS") ช่วง ("L1:L" & xLastRow)
สำหรับฉัน = 2 ถึง xLastRow
ถ้า xRg(I).Value > วันที่ แล้วก็ออก Sub
ถ้า xRg(I).Value <= Date แล้ว
xRg(I).EntireRow.Copy Destination:=Worksheets("ARCHIVED OASIS OPPORTUNITIES").Range("A" & J + 1)
xRg(I).ทั้งแถว.ลบ
เจ = เจ + 1
ฉัน = ฉัน - 1
End If
ต่อไป
ย่อยสิ้นสุด

คุณต้องใส่สคริปต์ VBA ลงในหน้าต่างโค้ด ThisWorkbook และบันทึกเวิร์กบุ๊กเป็น Excel Macro-Enabled Workbook
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
ขอบคุณคริสตัล มันใช้ได้ดี
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
คริสตัล ฉันค่อนข้างรีบร้อนที่จะตอบว่าโค้ดทำงาน ฉันเปิดสมุดงานของฉันวันนี้ และแถวที่มีรายการวันที่ก่อนหน้าในเซลล์คอลัมน์ L ยังคงอยู่ใน "แผ่นงานโอกาสโอเอซิสปัจจุบัน" และไม่ได้ย้ายไปยัง "แผ่นงานโอเอซิสที่เก็บถาวร" ตามที่คาดไว้ ความคิดใด ๆ ว่าทำไมถึงเป็นเช่นนี้?
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
เซลล์ที่ไฮไลต์จะอยู่ในคอลัมน์ L ตามคำถามด้านบน และเป็นเกณฑ์ (จนถึงวันที่ของวันนี้) สำหรับการย้ายแถวไปยังเวิร์กชีตใหม่ หวังว่าภาพนี้จะช่วยได้
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
นี่เป็นสำเนาของหน้าต่าง VBA ที่เกี่ยวข้องกับด้านบน
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
คริสตัล ฉันค่อนข้างรีบร้อนที่จะตอบว่าโค้ดทำงาน ฉันเปิดสมุดงานของฉันวันนี้ และแถวที่มีรายการวันที่ก่อนหน้าในเซลล์คอลัมน์ L ยังคงอยู่ใน "แผ่นงานโอกาสโอเอซิสปัจจุบัน" และไม่ได้ย้ายไปยัง "แผ่นงานโอเอซิสที่เก็บถาวร" ตามที่คาดไว้ ความคิดใด ๆ ว่าทำไมถึงเป็นเช่นนี้?
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
คริสตัล

เนื่องจากฉันไม่สามารถอัปโหลดสมุดงานได้ ฉันจะทำซ้ำแถวและคอลัมน์ที่นี่

ABCDEFGHIJKL
# ประเภท งดเว้นการชักชวน แก้ไข # วันที่ออก คำถาม สถานที่จัดส่งของลูกค้า สถานที่ ข้อเสนอโครงการ ครบกำหนด

1 SS SB 1234567 1 09/6/17 ไม่มีชื่อกองทัพ วาง Drive Tank 09/10/17

ด้วยรหัสด้านล่าง ฉันต้องการให้ย้ายทั้งแถวไปยังแผ่นงานใหม่เมื่อคอลัมน์ L ถึงวันที่ของวันนี้ นอกจากนี้ ถ้าฉันไม่ได้ทำเวิร์กชีตให้เสร็จเป็นเวลาหลายวัน ฉันต้องการให้ใช้การค้นหา "จนถึงวันที่ของวันนี้" ในคอลัมน์ L เพื่อทำเช่นเดียวกัน ฉันยังต้องการให้ทำเช่นนี้โดยอัตโนมัติเมื่อฉันเปิดสมุดงานถ้าเป็นไปได้ ปัจจุบัน ถ้าฉันป้อนวันที่ของวันนี้ในเซลล์ใดๆ ในแถว เช่น คอลัมน์ F เมื่อป้อนข้อมูล แถวทั้งหมดจะย้ายไปยังเวิร์กชีตที่เก็บถาวร (การใช้ Excel 2016)

[รหัสโมดูล 1]

ซับ เดฟวี()

Dim xRg เป็นช่วง

Dim xCell เป็นช่วง

หรี่ฉันนาน

Dim J ตราบ

I = แผ่นงาน ("โอกาสปัจจุบันของ OASIS") ใช้ช่วง.Rows.Count

J = แผ่นงาน ("โอกาสเก็บถาวร OASIS") ใช้ช่วง.Rows.Count

ถ้า J = 1 แล้ว
ถ้า Application.WorksheetFunction.CountA(Worksheets("ARCHIVED OASIS OPPORTUNITIES") UsedRange) = 0 แล้ว J = 0

End If

ตั้งค่า xRg = แผ่นงาน ("โอกาสปัจจุบันของ OASIS") ช่วง ("L1:L" & I)

เกี่ยวกับข้อผิดพลาดต่อไป

Application.ScreenUpdating = เท็จ

สำหรับแต่ละ xCell ใน xRg

ถ้า CStr(xCell.Value) = วันที่ แล้ว

xCell.EntireRow.Copy Destination:=Worksheets("ARCHIVED OASIS OPPORTUNITIES") ช่วง("A" & J + 1)
xCell.EntireRow.Delete

เจ = เจ + 1
End If

ต่อไป
Application.ScreenUpdating = จริง

ย่อยสิ้นสุด
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
[รหัสแผ่นที่ 1]

Worksheet_Change ย่อยส่วนตัว (เป้าหมายเป็นช่วง ByVal)
Dim xCell เป็นช่วง
หรี่ฉันนาน
เกี่ยวกับข้อผิดพลาดต่อไป
Application.ScreenUpdating = เท็จ
ตั้งค่า xCell = Target(1)
ถ้า xCell.Value = วันที่ แล้ว
I = แผ่นงาน ("โอกาสเก็บถาวร OASIS") ใช้ช่วง.Rows.Count
ถ้าฉัน = 1 แล้ว
ถ้า Application.WorksheetFunction.CountA(Worksheets("ARCHIVED OASIS OPPORTUNITIES") UsedRange) = 0 แล้ว I = 0 End If
แผ่นงาน xCell.EntireRow.Copy ("โอกาสในการเก็บถาวร OASIS") ช่วง ("A" & I + 1)
xCell.EntireRow.Delete
End If
Application.ScreenUpdating = จริง
ย่อยสิ้นสุด

หวังว่าข้างต้นจะช่วยได้ แต่ฉันไม่ใช่คน VBA ดังนั้นจึงไม่เข้าใจวิธีทำให้โค้ดทำในสิ่งที่ฉันต้องการ ความช่วยเหลือของคุณจะได้รับการชื่นชม
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
มีข้อผิดพลาดใหญ่ในสคริปต์ของคุณ!

สมมติว่าคุณตรวจพบว่าแถวที่ 7 มีคำว่า "เสร็จสิ้น" ในคอลัมน์ C ดังนั้นคุณจึงคัดลอกและลบแถวนั้น
เมื่อคุณลบแถวแล้ว แถวถัดไปในรายการจะเป็นแถวที่ 9 ไม่ใช่แถวที่ 8 เพราะเมื่อคุณลบบรรทัดที่ 7 แล้ว ตอนนี้เนื้อหาของบรรทัดที่ 8 จะอยู่ในบรรทัดที่ 7 และบรรทัดทั้งหมดก็เพิ่มขึ้น 1 แถว ดังนั้นแถวถัดไปที่จะตรวจสอบควรจะเป็นแถวที่ 8 แต่ตอนนี้มีข้อมูลที่ก่อนหน้านี้อยู่ในแถวที่ 9 ดังนั้นทุกครั้งที่คุณลบแถว คุณกำลังข้ามแถวเพื่อตรวจสอบจริงๆ !!!
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
เรียน ชอว์ อาลอน

ขอบคุณสำหรับความคิดเห็นของคุณ. รหัสได้รับการปรับปรุงโดยแก้ไขข้อผิดพลาด ขอบคุณมากสำหรับผู้ช่วยของคุณ

ขอแสดงความนับถือ Crystal
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
ฉันคิดว่าสิ่งนี้เกิดขึ้นกับฉัน มันคอยคัดลอกแถวเดิมซ้ำแล้วซ้ำอีก แม้ว่ามันจะบอกว่ารหัสได้รับการอัปเดตแล้ว นี่คือสิ่งที่ฉันมี:

ย่อย Cheezy()
'อัปเดตโดย Kutools for Excel 2017/8/28
Dim xRg เป็นช่วง
Dim xCell เป็นช่วง
หรี่ฉันนาน
Dim J ตราบ
หรี่ K ตราบ
ฉัน = แผ่นงาน ("การคาดการณ์การซื้อ") ใช้ช่วง.Rows.Count
J = แผ่นงาน ("Purchase Archive") ใช้ช่วง.Rows.Count
ถ้า J = 1 แล้ว
ถ้า Application.WorksheetFunction.CountA(Worksheets("Purchase Archive") UsedRange) = 0 แล้ว J = 0
End If
Set xRg = Worksheets("PURCHASE FORCAST")).Range("H3:H" & I)
เกี่ยวกับข้อผิดพลาดต่อไป
Application.ScreenUpdating = เท็จ
สำหรับ K = 1 ถึง xRg.Count
ถ้า CStr(xRg(K).Value) = "ใช่" แล้ว
xRg(K).EntireRow.Copy Destination:=Worksheets("Purchase Archive")).Range("A" & J + 1)
xRg(K).ทั้งแถว.ลบ
ถ้า CStr(xRg(K).Value) = "ใช่" แล้ว
K = K - 1
End If
เจ = เจ + 1
End If
ต่อไป
Application.ScreenUpdating = จริง
ย่อยสิ้นสุด
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดีเฟรด
ทุกครั้งที่คุณเรียกใช้โค้ด โค้ดจะค้นหาช่วงที่ระบุ ดังนั้นโค้ดจะคัดลอกแถวเดียวกันซ้ำแล้วซ้ำอีก เนื่องจากไม่สามารถระบุได้ว่าแถวใดถูกคัดลอกไปแล้ว เพื่อหลีกเลี่ยงการคัดลอกแถวเดียวกันซ้ำๆ คุณสามารถให้โค้ดทำงานโดยอัตโนมัติเมื่อป้อนค่าที่ตรงกันในเซลล์ที่ระบุ
ในเวิร์กชีตชื่อ "PURCHASE FORCAST" ให้คลิกขวาที่แท็บชีตแล้วคลิก ดูรหัส จากเมนูบริบท จากนั้นคัดลอกรหัส VBA ต่อไปนี้ในหน้าต่างแผ่นงาน (รหัส)

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Updated by Kutools for Excel 20220830
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("PURCHASE FORCAST").UsedRange.Rows.Count
J = Worksheets("Purchase Archive").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Purchase Archive").UsedRange) = 0 Then J = 0
End If
Set xRg = Worksheets("PURCHASE FORCAST").Range("H3:H" & I)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "Yes" Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Purchase Archive").Range("A" & J + 1)
xRg(K).EntireRow.Delete
If CStr(xRg(K).Value) = "Yes" Then
K = K - 1
End If
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
ใครสามารถช่วยฉันทำงานนี้ได้บ้าง ฉันได้ลองเปลี่ยนส่วนที่ต้องจับคู่กับไฟล์ของฉันแล้ว แต่สิ่งนี้ปรากฏขึ้นและฉันไม่แน่ใจว่าต้องทำอย่างไร
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
มันบอกว่าไฟล์ไม่รองรับเมื่อฉันพยายามอัปโหลดไฟล์ excel ขออภัย ... ดิ้นรนกับสิ่งนี้ในวันนี้
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
ฉันต้องการความช่วยเหลือสำหรับงานที่คล้ายกัน แต่แตกต่างกันเล็กน้อย ฉันมีตัวเลข 5 คอลัมน์ ประมาณ 25000 ต่อคอลัมน์ แต่ละคอลัมน์มีหัวเรื่อง 1-5 ฉันต้องการคัดลอกทั้งแถวไปยังชีตอื่นหากค่าของคอลัมน์ 1 มากกว่าศูนย์ OR คอลัมน์ที่ 2 มากกว่าศูนย์ , OR คอลัมน์ 3 น้อยกว่าศูนย์ หรือ คอลัมน์ 4 มีค่ามากกว่า 5 OR คอลัมน์ XNUMX มากกว่า XNUMX เป็นต้น เป็นไปได้ไหม
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
การอัพโหลดภาพไม่ทำงาน... ขออภัย
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดี,
โปรดใช้ปุ่มอัปโหลดของปุ่มนี้
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
เป้าหมายคือเพื่อดูว่ามีแก๊สเกินขีดจำกัดที่ฉันจะกำหนดในสูตรหรือไม่ ไข่ทั้งหมดจะถูกคัดลอกลงบนแผ่นงานใหม่

ขอบคุณมากสำหรับความช่วยเหลือใด ๆ
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
แนบรูปภาพ
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
ไมเคิลที่รัก
บางทีคุณสามารถแก้ปัญหานี้ได้โดยใช้ Add-in ของ Excel ที่นี่ฉันแนะนำให้คุณเลือกยูทิลิตี้เลือกเซลล์เฉพาะของ Kutools for Excel ด้วยยูทิลิตี้นี้ คุณสามารถเลือกแถวทั้งหมดในช่วง certian ได้อย่างง่ายดาย หากค่าของคอลัมน์ที่ระบุมากกว่าหรือน้อยกว่าตัวเลข หลังจากเลือกแถวที่จำเป็นทั้งหมดแล้ว คุณสามารถคัดลอกและวางแถวเหล่านั้นลงในเวิร์กชีตใหม่ได้ด้วยตนเอง ดูภาพที่แนบมาด้านล่าง

คุณสามารถทราบข้อมูลเพิ่มเติมเกี่ยวกับคุณลักษณะนี้ได้โดยทำตามไฮเปอร์ลิงก์ด้านล่าง
https://www.extendoffice.com/product/kutools-for-excel/excel-select-specific-cells-rows.html
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
ขอบคุณสำหรับสูตรนี้ แต่ฉันมีปัญหาซึ่งเมื่อฉันต้องการย้ายแถวไปยังชีตอื่น จะไม่เกิดขึ้นโดยอัตโนมัติ ขอสูตรอื่นได้ไหม ดังนั้นเมื่อใดก็ตามที่ฉันเปลี่ยนค่าของเซลล์ เซลล์จะย้ายโดยอัตโนมัติ


ขอบคุณ
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
เรียนจ่าง
ปริมาณรหัสจะไม่เกิดขึ้นโดยอัตโนมัติจนกว่าคุณจะเรียกใช้ปุ่มเรียกใช้ด้วยตนเอง
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดี

ฉันต้องการตั้งค่ามาโครนี้ แต่มี 2 ข้อโต้แย้ง ฉันจัดการเพื่อให้มาโครทำงานในไฟล์ของฉันโดยพิจารณาจากค่าของเซลล์ในคอลัมน์ O อย่างไรก็ตาม ฉันต้องการให้มาโครตรวจสอบว่ามีการกรอกคอลัมน์ S (หรือ <> "") ด้วยหรือไม่ ก่อนที่จะย้ายแถว . สุดท้ายนี้ ฉันยังต้องการให้แถวที่คัดลอกมีการจัดรูปแบบเดียวกับแถวในแผ่นงานที่สอง นั่นเปลี่ยนมาโครอย่างสมบูรณ์หรือไม่?
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
เรียนฮิวส์
ฉันไม่รู้ว่าฉันเข้าใจคุณถูกวิธีหรือไม่ คุณหมายความว่าถ้าเซลล์ในคอลัมน์ S ถูกกรอกและเซลล์ในคอลัมน์ O มีค่าที่แน่นอนในเวลาเดียวกัน ให้ย้ายแถวที่มีการจัดรูปแบบหรือไม่ ไม่อย่างนั้นอย่าขยับ?
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดีคริสตัล

ใช่นั่นคือสิ่งที่ฉันหมายถึง อันที่จริง ข้อมูลของฉันเกี่ยวกับโครงการ คอลัมน์ O ของฉันคือสถานะของโครงการของฉัน และ S คือวันที่สิ้นสุดของโครงการ
ฉันต้องการให้ผู้ใช้ของฉัน ผู้ที่มีข้อมูลและจำเป็นต้องแทรกข้อมูล เพื่อให้สามารถ "เก็บถาวร" โครงการได้ก็ต่อเมื่อพวกเขามีสถานะเป็น "ปิด" และพวกเขาได้แทรก "วันที่สิ้นสุด"


ฉันหวังว่านี่จะช่วยชี้แจงสิ่งต่าง ๆ
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
เรียนฮิวส์
ขอโทษที่ตอบช้า รหัส VBA ต่อไปนี้สามารถช่วยคุณแก้ปัญหาได้ โปรดทำตามขั้นตอนในบทความนี้เพื่อใช้สคริปต์ VBA

Sub MoveRowBasedOnCellValue ()
Dim xRgStatus เป็นช่วง
Dim xRgDate เป็นช่วง
หรี่ฉันนาน
Dim J ตราบ
หรี่ K ตราบ
I = แผ่นงาน("Sheet1").UsedRange.Rows.Count
J = แผ่นงาน ("Sheet2") .UsedRange.Rows.Count
ถ้า J = 1 แล้ว
ถ้า Application.WorksheetFunction.CountA(Worksheets("Sheet2")).UsedRange) = 0 แล้ว J = 0
End If
ตั้งค่า xRgStatus = Worksheets("Sheet1")).Range("O1:O" & I)
ตั้งค่า xRgDate = แผ่นงาน("Sheet1")).Range("S1:S" & I)
เกี่ยวกับข้อผิดพลาดต่อไป
Application.ScreenUpdating = เท็จ
Application.CutCopyMode = เท็จ
xRgStatus(1).EntireRow.Copy
แผ่นงาน("Sheet2")).ช่วง("A" & J + 1).วางแบบพิเศษ xlPasteAllUsingSourceTheme
เจ = เจ + 1
สำหรับ K = 2 ถึง xRgStatus.Count
ถ้า CStr(xRgStatus(K).Value) = "ปิด" แล้ว
ถ้า (xRgDate(K).Value <> "") และ (TypeName(xRgDate(K).Value) = "Date") แล้ว
xRgStatus(K).ทั้งแถว.Copy
แผ่นงาน("Sheet2")).ช่วง("A" & J + 1).วางแบบพิเศษ xlPasteAllUsingSourceTheme
เจ = เจ + 1
End If
End If
ต่อไป
Application.CutCopyMode = จริง
Application.ScreenUpdating = จริง
ย่อยสิ้นสุด
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
คริสตัลที่รัก

ขอบคุณมากสำหรับความช่วยเหลือของคุณ

ความนับถือ,

ฮิวจ์
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดี,


ฉันจะคัดลอกแถวแทนที่จะย้ายได้อย่างไร
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดี,


ฉันรู้ว่าสิ่งนี้ถูกโพสต์สองสามครั้ง แต่ฉันไม่พบคำตอบ ฉันจะคัดลอกวัสดุไปยังแผ่นงานใหม่โดยไม่ลบออกจากแผ่นงานต้นฉบับได้อย่างไร
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
ไมค์ที่รัก
ถ้าคุณต้องการคัดลอกแถวแทนที่จะลบออก โค้ด VBA ด้านล่างสามารถช่วยคุณได้ ขอบคุณสำหรับความคิดเห็นของคุณ!

ย่อย Cheezy()
Dim xRg เป็นช่วง
Dim xCell เป็นช่วง
หรี่ฉันนาน
Dim J ตราบ
หรี่ K ตราบ
I = แผ่นงาน("Sheet1").UsedRange.Rows.Count
J = แผ่นงาน ("Sheet2") .UsedRange.Rows.Count
ถ้า J = 1 แล้ว
ถ้า Application.WorksheetFunction.CountA(Worksheets("Sheet2")).UsedRange) = 0 แล้ว J = 0
End If
ตั้งค่า xRg = แผ่นงาน("Sheet1")).ช่วง("C1:C" & I)
เกี่ยวกับข้อผิดพลาดต่อไป
Application.ScreenUpdating = เท็จ
สำหรับ K = 1 ถึง xRg.Count
ถ้า CStr(xRg(K).Value) = "เสร็จสิ้น" แล้ว
xRg(K).EntireRow.Copy Destination:=Worksheets("Sheet2")).Range("A" & J + 1)
เจ = เจ + 1
End If
ต่อไป
Application.ScreenUpdating = จริง
ย่อยสิ้นสุด
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
สวัสดี

ฉันยังใหม่กับการใช้มาโคร เป็นไปได้ไหมที่จะวางข้อมูลด้านล่างหลังค่าหนึ่งและจะถูกทำซ้ำจนกระทั่งสิ้นสุดคอลัมน์
อย่างนี้:

โอน "สีน้ำเงิน" หลัง "สี"

A1 = สีน้ำเงิน
A5= สี
A6= (โอน "สีน้ำเงิน" ที่นี่)
และอื่น ๆ ...
ความคิดเห็นนี้ถูกย่อให้เล็กสุดโดยผู้ดำเนินรายการบนเว็บไซต์
จอห์นที่รัก,
คุณหมายถึงถ้าเซลล์มี "สี" ในคอลัมน์ ให้คัดลอกข้อความของเซลล์แรกไปยังเซลล์ที่อยู่ใต้ "สี" แล้วคัดลอกข้อความนี้ซ้ำไปจนจบคอลัมน์หรือไม่
มีความคิดเห็นยังไม่มีการโพสต์ที่นี่
โหลดเพิ่มเติม
แสดงความคิดเห็นของคุณ
โพสต์ในฐานะแขก
×
ให้คะแนนโพสต์นี้:
0   ตัวอักษร
สถานที่แนะนำ

ช่องทางอื่นๆ

ลิขสิทธิ์© 2009 - wwwextendoffice.com | สงวนลิขสิทธิ์. ขับเคลื่อนโดย ExtendOffice. | แผนผังเว็บไซต์
Microsoft และโลโก้ Office เป็นเครื่องหมายการค้าหรือเครื่องหมายการค้าจดทะเบียนของ Microsoft Corporation ในสหรัฐอเมริกาและ / หรือประเทศอื่น ๆ
ได้รับการปกป้องโดย Sectigo SSL