![](/img/trans.png)
[英]Excel VBA code to copy a range of cells in a row and paste in a different sheet but same row/range, when the value on 1st cell changes
[英]If cell in a range has value “x” copy and paste a range of cells into a different sheet
我不是行業程序員,但是出於好奇和自身利益,我試圖使我每天使用的一小部分報告自動化。 基本上,我們接收並手動輸入聯系信息(姓名,電子郵件,電話號碼等),並標記某人有興趣加入的選定組。 然后,我們將輸入的聯系信息復制並粘貼到每個組的不同工作表中。
我想要一個宏,用於檢查每個興趣組的特定列是否為“ x”,以及是否找到該值,然后將收集的聯系信息粘貼到特定興趣組工作表中。 人們可以選擇多個興趣組,並將他們的聯系信息添加到每個單獨的興趣組電子表格中。
報告列如下所示:
Group 1 Group 2 Group 3 Name Organization Phone E-mail Notes
Row Contact Information looks similar to:
x x John ABC Inc. 000-000-0000 john.smith@fake.com Call me ASAP!
宏會檢查我對第1組感興趣的列,如果找到“ x”,則會將整個范圍復制到第1組工作表。
我希望它能夠檢查“ x”的多個列(即組1、2、3),然后將這些列右側的信息復制並粘貼到該組的適當工作表中。 如果他們對多個組感興趣,則應將其聯系信息復制到每個特定的工作表中。\\
我是否需要為每個組工作表設置單獨的計數器,是否可以編寫if語句以檢查每個列中的x,然后運行適當的代碼來復制並粘貼到該組中?
Sub Update()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target1 As Worksheet
Dim Target2 As Worksheet
Dim Target3 As Worksheet
Set Source = ActiveWorkbook.Worksheets("Interest Group Tracking")
Set Target1 = ActiveWorkbook.Worksheets("Group 1")
j = 1 'Start copying to row 1 in target sheet
For Each c In Source.Range("A1:A1000") 'not sure if there is a way to not set a limit for the range
If c = "x" Then
Source.Rows(c.Row).Copy Target1.Rows(j + 1)
j = j + 1
End If
Next c
End Sub
除了偶爾的語法外,沒有其他錯誤,但實際上並不知道如何構造用於檢查每個組的循環。 我將繼續研究和測試發現的問題,並在需要時進行更新。
看看是否有幫助...我已經在代碼中添加了注釋,但是請隨時詢問其他問題:
Sub Update()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim Source As Worksheet: Set Source = wb.Worksheets("Interest Group Tracking")
Dim Target As Worksheet
Dim R As Long, C As Long, lRowSrc As Long, lRowDst As Long
With Source
lRowSrc = .Cells(.Rows.Count, 1).End(xlUp).Row 'get the last row in your source sheet
For R = 1 To lRowSrc 'Loop through all rows in the source
For C = 1 To 3 'Loop through the 3 columns in the source
If .Cells(R, C) = "x" Then
Set Target = wb.Worksheets("Group " & C) 'Assuming all groups have the same names, Group 1, Group 2, etc
lRowDst = Target.Cells(Target.Rows.Count, 1).End(xlUp).Row + 1 'get last row + 1 in the target sheet
.Rows(R).Copy Target.Rows(lRowDst)
End If
Next C
Next R
End With
End Sub
編輯:其他示例
Sub Update()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim Source As Worksheet: Set Source = wb.Worksheets("Interest Group Tracking")
Dim Target As Worksheet
Dim shNames() As String: shNames = Split("ABC Group,Voter Accesibility,Animal Rights Activism", ",") 'Add sheet names here in the order of the groups
Dim R As Long, C As Long, lRowSrc As Long, lColSrc As Long, lRowDst As Long
With Source
lRowSrc = .Cells(.Rows.Count, 1).End(xlUp).Row 'get the last row in your source sheet
For R = 1 To lRowSrc 'Loop through all rows in the source
For C = 1 To 3 'Loop through the 3 columns in the source
If .Cells(R, C) = "x" Then
Set Target = wb.Worksheets(shNames(C - 1)) 'shNames array starts at 0
lRowDst = Target.Cells(Target.Rows.Count, 1).End(xlUp).Row + 1 'get last row + 1 in the target sheet
Target.Range(Target.Cells(lRowDst, 1), Target.Cells(lRowDst, 10 - C + 1)) = .Range(.Cells(R, C), .Cells(R, 10)).Value 'allocate the values
End If
Next C
Next R
End With
End Sub
最后,我更改了主要邏輯,但這應該可行。 而不是復制和粘貼,我只是使group1工作表中的范圍等於行的范圍。 我還使用最后使用的行。
Sub Update()
Dim c As Range
Dim j As Integer
Dim k As Integer
Dim Source As Worksheet
Dim Target1 As Worksheet
Dim Target2 As Worksheet
Dim Target3 As Worksheet
Dim curSheet As Worksheet
Dim lastRow, lastRow1, lastRow2, lastRow3, lastCol As Long
Dim group1, group2, group3, curGroup As Long
Set Source = ActiveWorkbook.Worksheets("Interest Group Tracking")
Set Target1 = ActiveWorkbook.Worksheets("Group 1")
Set Target2 = ActiveWorkbook.Worksheets("Group 2")
Set Target3 = ActiveWorkbook.Worksheets("Group 3")
j = 1
group1 = 1
group2 = 1
group3 = 1
With Source
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
lastRow1 = .Cells(.Rows.Count, 1).End(xlUp).Row
lastRow2 = .Cells(.Rows.Count, 2).End(xlUp).Row
lastRow3 = .Cells(.Rows.Count, 3).End(xlUp).Row
If lastRow1 > lastRow2 And lastRow1 > lastRow3 Then
lastRow = lastRow1
End If
If lastRow2 > lastRow1 And lastRow2 > lastRow3 Then
lastRow = lastRow2
End If
If lastRow3 > lastRow1 And lastRow3 > lastRow2 Then
lastRow = lastRow3
End If
For j = 1 To lastRow
For k = 1 To 3
If .Cells(j, k) = "x" Then
Set curSheet = ActiveWorkbook.Sheets("Group" & " " & k)
If k = 1 Then
curGroup = group1
ElseIf k = 2 Then
curGroup = group2
ElseIf k = 3 Then
curGroup = group3
Else
GoTo line1
End If
curSheet.Range(curSheet.Cells(curGroup, 1), curSheet.Cells(curGroup, lastCol)).Value = .Range(.Cells(j, 1), .Cells(j, lastCol)).Value
End If
If k = 1 Then
group1 = group1 + 1
ElseIf k = 2 Then
group2 = group2 + 1
ElseIf k = 3 Then
group3 = group3 + 1
End If
line1:
Next k
Next j
End With
End Sub
另一種方式。
Option Explicit
Sub CopyData()
Dim srcWB As Workbook
Dim srcWS As Worksheet
Dim destWS As Worksheet
Dim CopyRange As Variant
Dim i As Long, j As Long
Dim srcLRow As Long, destLRow As Long
Dim LCol As Long
Set srcWB = ActiveWorkbook
Set srcWS = srcWB.ActiveSheet
srcLRow = srcWS.Cells(srcWS.Rows.Count, "A").End(xlUp).Row
'loop through column 1 to 3
For i = 1 To 3
For j = 2 To srcLRow
'loop through rows
If srcWS.Cells(j, i).value = "x" Then
Set destWS = srcWB.Sheets("Sheet" & i)
destLRow = destWS.Cells(destWS.Rows.Count, "A").End(xlUp).Row
LCol = srcWS.Cells(j, srcWS.Columns.Count).End(xlToLeft).Column 'if you need to grab last used column
' Copy data
Set CopyRange = srcWS.Range(Cells(j, 1), Cells(j, LCol))
CopyRange.Copy
' paste data from one sht to another
destWS.Cells(destLRow + 1, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=False
Application.CutCopyMode = False
End If
Next j
Next i
MsgBox "Process completed!", vbInformation
End Sub
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.