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

Sut i gysoni cwymplenni mewn taflenni gwaith lluosog yn Excel?

Tybiwch fod gennych chi gwymplenni ar sawl taflen waith mewn llyfr gwaith sy'n cynnwys yr un eitemau cwymplen yn union. Nawr rydych chi am gydamseru'r cwymplenni ar draws taflenni gwaith fel bod y rhestrau cwympo mewn taflenni gwaith eraill yn cael eu cydamseru'n awtomatig ar ôl i chi ddewis eitem o gwymplen mewn un daflen waith. Mae'r erthygl hon yn darparu cod VBA i'ch helpu i ddatrys y broblem hon.

Cydamseru cwymplenni mewn taflenni gwaith lluosog gyda chod VBA


Cydamseru cwymplenni mewn taflenni gwaith lluosog gyda chod VBA

Er enghraifft, mae'r cwymplenni mewn pum taflen waith a enwir dalen 1, dalen 2, ..., Taflen 5, i gydamseru'r cwymplenni mewn taflenni gwaith eraill yn ôl y cwymplen yn Nhaflen 1, cymhwyswch y cod VBA canlynol i'w wneud.

1. Agorwch Sheet1, de-gliciwch ar y tab taflen a dewiswch Gweld y Cod o'r ddewislen cywir ar y dde.

2. Yn y Microsoft Visual Basic ar gyfer Ceisiadau ffenestr, gludwch y cod VBA canlynol i mewn i'r Dalen 1 (Cod) ffenestr.

Cod VBA: Cydamseru'r gwymplen mewn taflenni gwaith lluosog

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20220815
    Dim tSheet1 As Worksheet
    Dim tRange As Range
    Dim xRangeStr As String
    On Error Resume Next
    If Target.Count > 1 Then Exit Sub
    
    xRangeStr = "A2:A11"

    Set tRange = Intersect(Target, Range(xRangeStr))
    If Not tRange Is Nothing Then
        xRangeStr = tRange.Address
        Application.EnableEvents = False
        Set tSheet1 = ActiveWorkbook.Worksheets("Sheet2")
        tSheet1.Range(xRangeStr).Value = Target.Value
        Set tSheet1 = ActiveWorkbook.Worksheets("Sheet3")
        tSheet1.Range(xRangeStr).Value = Target.Value
        Set tSheet1 = ActiveWorkbook.Worksheets("Sheet4")
        tSheet1.Range(xRangeStr).Value = Target.Value
        Set tSheet1 = ActiveWorkbook.Worksheets("Sheet5")
        tSheet1.Range(xRangeStr).Value = Target.Value
        Application.EnableEvents = True
    End If
    
End Sub

Nodiadau:

1) Yn y cod, A2: A11 yw'r ystod sy'n cynnwys y gwymplen. Sicrhewch fod yr holl gwymplenni yn yr un ystod ar draws gwahanol daflenni gwaith.
2) Taflen2, Taflen3, Taflen4 ac Sheet5 yn daflenni gwaith sy'n cynnwys cwymplenni rydych am eu cysoni yn seiliedig ar y gwymplen yn Nhaflen 1;
3) I ychwanegu mwy o daflenni gwaith yn y cod, ychwanegwch y ddwy linell ganlynol cyn y llinell “Application.EnableEvents = Gwir”, yna newidiwch enw'r ddalen “Sheet5” i'r enw sydd ei angen arnoch chi.
Gosod tSheet1 = ActiveWorkbook.Worksheets("Taflen5")
tSheet1.Range(xRangeStr).Value = Targed.Gwerth

3. Gwasgwch y Alt + Q allweddi i gau'r Microsoft Visual Basic ar gyfer Ceisiadau ffenestr.

O hyn ymlaen, pan fyddwch chi'n dewis eitem o'r gwymplen i mewn Taflen 1, bydd y cwymplenni yn y taflenni gwaith penodedig yn cael eu cysoni'n awtomatig i gael yr un dewis. Gweler y demo isod.


Demo: Cydamseru Rhestrau Gollwng Mewn Taflenni Gwaith Lluosog Yn Excel


Yr Offer Cynhyrchedd Swyddfa Gorau

Mae Kutools for Excel yn Datrys y rhan fwyaf o'ch Problemau, ac yn Cynyddu Eich Cynhyrchedd 80%

  • Ailddefnyddio: Mewnosod yn gyflym fformwlâu cymhleth, siartiau ac unrhyw beth rydych chi wedi'i ddefnyddio o'r blaen; Amgryptio Celloedd gyda chyfrinair; Creu Rhestr Bostio ac anfon e-byst ...
  • Bar Fformiwla Gwych (golygu llinellau lluosog o destun a fformiwla yn hawdd); Cynllun Darllen (darllen a golygu nifer fawr o gelloedd yn hawdd); Gludo i'r Ystod Hidlo...
  • Uno Celloedd / Rhesi / Colofnau heb golli Data; Cynnwys Celloedd Hollt; Cyfuno Rhesi / Colofnau Dyblyg... Atal Celloedd Dyblyg; Cymharwch y Meysydd...
  • Dewiswch Dyblyg neu Unigryw Rhesi; Dewiswch Blank Rows (mae pob cell yn wag); Darganfyddiad Gwych a Darganfyddiad Niwlog mewn Llawer o Lyfrau Gwaith; Dewis ar Hap ...
  • Copi Union Celloedd Lluosog heb newid cyfeirnod fformiwla; Auto Creu Cyfeiriadau i Daflenni Lluosog; Mewnosod Bwledi, Blychau Gwirio a mwy ...
  • Testun Detholiad, Ychwanegu Testun, Tynnu yn ôl Swydd, Tynnwch y Gofod; Creu ac Argraffu Subtotals Paging; Trosi rhwng Cynnwys a Sylwadau Celloedd...
  • Hidlo Super (arbed a chymhwyso cynlluniau hidlo i ddalenni eraill); Trefnu Uwch yn ôl mis / wythnos / dydd, amlder a mwy; Hidlo Arbennig gan feiddgar, italig ...
  • Cyfuno Llyfrau Gwaith a Thaflenni Gwaith; Uno Tablau yn seiliedig ar golofnau allweddol; Rhannwch Ddata yn Daflenni Lluosog; Trosi Swp xls, xlsx a PDF...
  • Mwy na 300 o nodweddion pwerus. Yn cefnogi Office / Excel 2007-2021 a 365. Yn cefnogi pob iaith. Defnydd hawdd yn eich menter neu sefydliad. Nodweddion llawn treial am ddim 30 diwrnod. Gwarant arian yn ôl 60 diwrnod.
tab kte 201905

Mae Tab Office yn Dod â rhyngwyneb Tabbed i'r Swyddfa, a Gwneud Eich Gwaith yn Haws o lawer

  • Galluogi golygu a darllen tabbed yn Word, Excel, PowerPoint, Cyhoeddwr, Mynediad, Visio a Phrosiect.
  • Agor a chreu dogfennau lluosog mewn tabiau newydd o'r un ffenestr, yn hytrach nag mewn ffenestri newydd.
  • Yn cynyddu eich cynhyrchiant 50%, ac yn lleihau cannoedd o gliciau llygoden i chi bob dydd!
gwaelod officetab
sylwadau (5)
Dim sgôr eto. Byddwch y cyntaf i sgorio!
Lleihawyd y sylw hwn gan y safonwr ar y wefan
Heia,

Sut alla i wneud hyn os yw fy nghwympiadau mewn ystodau gwahanol? I ymhelaethu, mae gennyf un cwymplen yn nhaflen 7 sydd yng nghell B7 a'r un cwymplen ar ddalen 6 yng nghell B2.

Diolch yn fawr,
Elaine
Lleihawyd y sylw hwn gan y safonwr ar y wefan
Helo E,
Gall y cod VBA canlynol helpu.
Yma rwy'n cymryd Sheet6 fel y brif daflen waith, cliciwch ar y dde ar y tab taflen, dewiswch Gweld Cod o'r ddewislen clicio ar y dde, yna copïwch y cod canlynol yn y ffenestr Sheet6 (Code). Pan fyddwch chi'n dewis unrhyw eitem o'r gwymplen yn B2 o Daflen6, bydd y gwymplen yn B7 o Daflen7 yn cael ei chynamseru i gael yr un eitem ddethol.

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20221025
    Dim tSheet1 As Worksheet
    Dim tRange As Range
    Dim xRangeStr As String
    On Error Resume Next
    If Target.Count > 1 Then Exit Sub
    
    xRangeStr = "B2"
    
    Set tRange = Range("B7")
    If Not tRange Is Nothing Then
        xRangeStr = tRange.Address
        Application.EnableEvents = False
        Set tSheet1 = ActiveWorkbook.Worksheets("Sheet7")
        tSheet1.Range(xRangeStr).Value = Target.Value
        Application.EnableEvents = True
    End If
    
End Sub
Lleihawyd y sylw hwn gan y safonwr ar y wefan
Helo Crystal,

Diolch yn fawr iawn am eich ymateb, fe weithiodd eich cod! Mae gen i gell o dan b2 a b7, b3 a b8 yn y drefn honno sydd angen yr un swyddogaeth. Ceisiais ailysgrifennu'ch cod fel y dangosir isod, ond ni weithiodd hyn. Achosodd i b7 yn lle b8 newid pan newidiais b3. A allech chi nodi'r hyn yr wyf yn ei wneud o'i le?

Diolch yn fawr!

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20221025
    Dim tSheet1 As Worksheet
    Dim tRange1 As Range
    Dime tRange2 As Range
    Dim xRangeStr1 As String
    Dim xRangeStr2 As String
    On Error Resume Next
    If Target.Count > 1 Then Exit Sub
    
    xRangeStr1 = "B2"
    xRangeStr2="B3"
    
    Set tRange1 = Range("B7")
    If Not tRange1 Is Nothing Then
        xRangeStr1 = tRange1.Address
        Application.EnableEvents = False
        Set tSheet1 = ActiveWorkbook.Worksheets("Sheet7")
        tSheet1.Range(xRangeStr1).Value = Target.Value
        Application.EnableEvents = True
    End If
    
    Set tRange2 = Range("B8")
    If Not tRange2 Is Nothing Then
        xRangeStr2 = tRange2.Address
        Application.EnableEvents = False
        Set tSheet1 = ActiveWorkbook.Worksheets("Sheet7")
        tSheet1.Range(xRangeStr2).Value = Target.Value
        Application.EnableEvents = True
    End If

End Sub
Lleihawyd y sylw hwn gan y safonwr ar y wefan
Helo E,
Mae rhywbeth o'i le ar y cod VBA a atebais i chi uchod.
Ar gyfer y cwestiwn newydd a grybwyllwyd gennych, rhowch gynnig ar y cod canlynol.

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20221031
    
    Dim xBool1 As Boolean
    Dim xBool2 As Boolean
    Dim xRgStr As String
    Dim tRange As Range
    
    xRangeStr1 = "B2"
    xRangeStr2 = "B3"
    xRgStr = ""
    
    On Error Resume Next
    If Target.Count > 1 Then Exit Sub
    xBool1 = Intersect(Target, Range(xRangeStr1)) Is Nothing
    xBool2 = Intersect(Target, Range(xRangeStr2)) Is Nothing
    
    If xBool1 And xBool2 Then Exit Sub
    
    xRgStr = Target.Address(False, False, xlA1, False, False)
    
    If Target.Address(False, False, xlA1, False, False) = xRangeStr1 Then
        xRgStr = "b7"
    ElseIf Target.Address(False, False, xlA1, False, False) = xRangeStr2 Then
        xRgStr = "b8"
    End If
    If xRgStr = "" Then Exit Sub
    
    Application.EnableEvents = False
    Set tSheet1 = ActiveWorkbook.Worksheets("Sheet7")
    tSheet1.Range(xRgStr).Value = Target.Value
    Application.EnableEvents = True

End Sub
Lleihawyd y sylw hwn gan y safonwr ar y wefan
Grisial,

Diolch yn fawr iawn am eich ymateb, fe weithiodd hyn! Sut allwn i addasu'r cod i ychwanegu cell arall yn yr un ddalen 6, B3 yr oedd angen ei chydamseru â B8 yn nhaflen 7 hefyd? Rwyf wedi ceisio ei addasu isod, ond yn y diwedd mae'n rhoi cynnwys B3 ar ddalen 6 yn B7 ar ddalen 7 yn lle B8.


Is-daflen Waith Breifat_Newid(Targed ByVal Fel Ystod)
'Diweddarwyd gan Extendoffice 20221025
Dim t Sheet1 Fel Taflen Waith
Dim trange1 As Range
Dim trange2 As Range
Dim xRangeStr1 Fel Llinyn
Dim xRangeStr2 Fel Llinyn
Ar Ail-ddechrau Gwall Nesaf
Os Targed.Cyfrif > 1 Yna Gadael Is

xRangeStr1 = "B2"
xRangeStr2 = "B3"

Gosod tRange1 = Ystod ("B7")
Os Nad yw trange1 Yn Dim Yna
xRangeStr1 = tRange1.Address
Application.EnableEvents = Gau
Gosod tSheet1 = ActiveWorkbook.Worksheets("Taflen7")
tSheet1.Range(xRangeStr1).Gwerth = Targed.Gwerth
Application.EnableEvents = Gwir
Gorffennwch Os

Gosod tRange2 = Ystod ("B8")
Os Nad yw trange2 Yn Dim Yna
xRangeStr2 = tRange2.Address
Application.EnableEvents = Gau
Gosod tSheet1 = ActiveWorkbook.Worksheets("Taflen7")
tSheet1.Range(xRangeStr2).Gwerth = Targed.Gwerth
Application.EnableEvents = Gwir
Gorffennwch Os

Is-End
Nid oes unrhyw sylwadau wedi'u postio yma eto
Gadewch eich sylwadau
Postio fel Gwestai
×
Graddiwch y swydd hon:
0   Cymeriadau
Lleoliadau a Awgrymir

Dilynwch ni

Hawlfraint © 2009 - www.extendoffice.com. | Cedwir pob hawl. Wedi ei bweru gan ExtendOffice. | Map o'r safle
Mae Microsoft a logo'r Swyddfa yn nodau masnach neu'n nodau masnach cofrestredig Microsoft Corporation yn yr Unol Daleithiau a / neu wledydd eraill.
Wedi'i warchod gan Sectigo SSL