Question

我尝试创建一个宏（并搜索谷歌的感觉就像永远一样），但仍未解决我的问题，我可以选择一个或多个单元格，例如列A并运行宏。然后宏应该将来自所选单元格行中的几个单元格的粘贴数据复制到另一个工作簿中的特定单元格。我希望到目前为止它是有道理的。

无论如何，这是一个例子：
如果我选择A1，A2，A4并运行宏，则应将后续单元格复制到新工作簿中：

A1, A2, A4 --> B1, B2, B4
F1, F2, F4 --> D1, D2, D4
E1, E2, E4 --> F1, F2, F4
etc. so I can edit/change it depending on my need.

如果可能，我实际上希望粘贴的数据从第13行开始。如果代码可以被评论，我将不胜感激，因此我可以了解更多信息：）

解决方案
*更新*

Sub CopyData()
Dim wkbCurrent, wkbNew As Workbook
Set wkbCurrent = ActiveWorkbook
Dim valg, c, LastCell As Range
Set valg = Selection
Dim wkbPath, wkbFileName, lastRow As String
Dim LastRowInput As Long
Dim lrow, rwCount As Long

Application.ScreenUpdating = False

On Error GoTo errHandler

wkbPath = ActiveWorkbook.Path & "\"
wkbFileName = Dir(wkbPath & "CIF LISTEN.xlsm")

Set wkbNew = Workbooks.Open(wkbPath & "CIF LISTEN.xlsm")

LastRowInput = Cells(Rows.count, "A").End(xlDown).Row

' If nothing is selected in column A
' GoTo Error Handling
If valg.Cells(1, 1) = 0 Then
    GoTo errHandler
End If

For Each c In valg.Cells
    lrow = wkbNew.Worksheets(1).Range("B1").Offset(wkbNew.Worksheets(1).Rows.count - 1, 0).End(xlUp).Row + 1

    wkbCurrent.ActiveSheet.Range("A" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("B" & lrow)
    wkbCurrent.ActiveSheet.Range("E" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("A" & lrow)
    wkbCurrent.ActiveSheet.Range("F" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("F" & lrow)
Next

'Range("A10").Value = "COMMENTS: " & Selection.Rows.count & " Suppliers Added"

' wkbNew.Close False
' wkbfilename = Dir

' Find the number of rows that is copied over
wkbCurrent.ActiveSheet.Activate
areaCount = Selection.Areas.count
If areaCount <= 1 Then
    MsgBox "The selection contains " & Selection.Rows.count & " suppliers."
    ' Write it in A10 in CIF LISTEN
    wkbNew.Worksheets(1).Range("A10").Value = "COMMENTS: " & Selection.Rows.count & " Suppliers Added"
Else
    I = 1
    For Each a In Selection.Areas
        'MsgBox "Area " & I & " of the selection contains " & _
        a.Rows.count & " rows."
        I = I + 1
        rwCount = rwCount + a.Rows.count
    Next a
    MsgBox "The selection contains " & rwCount & " suppliers."
    ' Write it in A10 in CIF LISTEN
    wkbNew.Worksheets(1).Range("A10").Value = "COMMENTS: " & rwCount & " Suppliers Added"
End If

Application.ScreenUpdating = True

' Error Handling
exitHandler:
wkbNew.Close SaveChanges:=False
Exit Sub
errHandler:
MsgBox "Please select cell(s) in column A", vbCritical, "Error"
Resume exitHandler
End Sub

Answer 1

我也是vba的新手，以下是我的尝试

Sub Main()

'Decoration of selected range
    Dim rngCopy As Range
    Set rngCopy = Selection
'Get Column number for selected range
    Dim n As Integer
    n = ActiveCell.Column

'Control which column to paste the data
    If n = 1 Then
        ActiveCell.Select
        rngCopy.Copy

        Set NewBook = Workbooks.Add     'Create new workbook
        Cells(13, 2).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    ElseIf n = 2 Then
        ActiveCell.Select
        rngCopy.Copy

        Set NewBook = Workbooks.Add
        Cells(13, 4).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    ElseIf n = 3 Then
        ActiveCell.Select
        rngCopy.Copy

        Set NewBook = Workbooks.Add
        Cells(13, 6).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Else
        MsgBox "Please advise which column i should paste in the code"

    End If

End Sub

这不是一个优雅的代码，您需要微调代码粘贴代码的位置。例如，如果选定的列号为1（列A），则需要粘贴到第2列（B列）以获取新工作簿。

Answer 2

解决方案
*更新*

Sub CopyData()
Dim wkbCurrent, wkbNew As Workbook
Set wkbCurrent = ActiveWorkbook
Dim valg, c, LastCell As Range
Set valg = Selection
Dim wkbPath, wkbFileName, lastRow As String
Dim LastRowInput As Long
Dim lrow, rwCount As Long

Application.ScreenUpdating = False

On Error GoTo errHandler

wkbPath = ActiveWorkbook.Path & "\"
wkbFileName = Dir(wkbPath & "CIF LISTEN.xlsm")

Set wkbNew = Workbooks.Open(wkbPath & "CIF LISTEN.xlsm")

LastRowInput = Cells(Rows.count, "A").End(xlDown).Row

' If nothing is selected in column A
' GoTo Error Handling
If valg.Cells(1, 1) = 0 Then
GoTo errHandler
End If

For Each c In valg.Cells
lrow = wkbNew.Worksheets(1).Range("B1").Offset(wkbNew.Worksheets(1).Rows.count - 1, 0).End(xlUp).Row + 1

    wkbCurrent.ActiveSheet.Range("A" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("B" & lrow)
    wkbCurrent.ActiveSheet.Range("E" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("A" & lrow)
    wkbCurrent.ActiveSheet.Range("F" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("F" & lrow)
Next

'Range("A10").Value = "COMMENTS: " & Selection.Rows.count & " Suppliers Added"

' wkbNew.Close False
' wkbfilename = Dir

' Find the number of rows that is copied over
wkbCurrent.ActiveSheet.Activate
areaCount = Selection.Areas.count
If areaCount <= 1 Then
MsgBox "The selection contains " & Selection.Rows.count & " suppliers."
' Write it in A10 in CIF LISTEN
wkbNew.Worksheets(1).Range("A10").Value = "COMMENTS: " & Selection.Rows.count & " Suppliers Added"
Else
I = 1
 For Each a In Selection.Areas
 'MsgBox "Area " & I & " of the selection contains " & _
 a.Rows.count & " rows."
I = I + 1
rwCount = rwCount + a.Rows.count
Next a
MsgBox "The selection contains " & rwCount & " suppliers."
' Write it in A10 in CIF LISTEN
wkbNew.Worksheets(1).Range("A10").Value = "COMMENTS: " & rwCount & " Suppliers Added"
End If

Application.ScreenUpdating = True

' Error Handling
exitHandler:
wkbNew.Close SaveChanges:=False
Exit Sub
errHandler:
MsgBox "Please select cell(s) in column A", vbCritical, "Error"
Resume exitHandler
End Sub

VBA：在列中选择单元格，从选定单元格的行复制多个单元格并复制到另一个工作簿中

2 个答案: