2

誰かが何かを言う前に、私はこの同様のアイデアに関連するいくつかの投稿を調べました（異なる検索基準を実行し、それを変更します）が、マクロを機能させることができません。これはおそらくプログラミングの知識が不足しているためです。私がやりたいのは、WORKSHEET 1で電子メールアドレスを検索し、それが見つかった場合は、行全体をWORKSHEET2の次の空き行にコピーすることです。私はExcel2003を使用しています（はい、私は古い泥棒です！）。

4

3 に答える 3

1

実際、あなたは賢い人だと思います。個人的に私は多くの理由で2007/2010のユーザーインターフェースを嫌います。

あなたの質問に答えるには、これが理にかなっているかどうかを確認してください。（それは速くて汚いので、防弾ではありません。しかし、それはあなたに出発点を与えるはずです。）

Sub FindAndCopyEmailAddress()


Dim vnt_Input As Variant
Dim rng_Found As Excel.Range
Dim wks1 As Excel.Worksheet, wks2 As Excel.Worksheet
Dim rng_target As Excel.Range
Dim l_FreeRow As Long

'Check that the sheets are there, and get a reference to
'them. Change the sheet names if they're different in yours.
On Error Resume Next
Set wks1 = ThisWorkbook.Worksheets("Sheet1")
Set wks2 = ThisWorkbook.Worksheets("Sheet2")

'If a runtime error occurs, jump to the line marked 
'ErrorHandler to display the details before exiting the 
'procedure.
On Error GoTo ErrorHandler

'Creating a message to tell *which* one is missing is left as an exercise
'for the reader, if you wish to.
If wks1 Is Nothing Or wks2 Is Nothing Then
    Err.Raise vbObjectError + 20000, , "Cannot find sheet1 or 2"
End If

'Get the e-mail address that you want to find.
'You don't HAVE to use an InputBox; you could, for instance,
'pick it up from the contents of another cell; that's up
'to you.
vnt_Input = InputBox("Please enter the address that you're looking for", "Address Copier")

'If the user cancels the input box, exit the program.
'Do the same if there's no entry.
'Rather than exiting immediately we jump to the label
'ExitPoint so that all references are cleaned up.
'Perhaps unnecessary, but I prefer good housekeeping.
If vnt_Input = "" Then GoTo ExitPoint

'Find the range containing the e-mail address, if there is one.
'wks1.Cells essentially means "Look in all of the cells in the sheet
'that we assigned to the wks1 variable above". You don't have to be
'on that sheet to do this, you can be in any sheet of the workbook.
Set rng_Found = wks1.Cells.Find(What:=vnt_Input, After:=ActiveCell, _
 LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
 SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

'The range will be Nothing if the address is not found. In that case, exit.
If rng_Found Is Nothing Then
    MsgBox "Cannot find that address."
    GoTo ExitPoint
End If

'Find the last free row in sheet2
'The .Row property tells us where the used range starts,
'the .Rows property tells us how many to add on to that to 
'find the first free one.
'The only slight problem is that if there are no cells at
'all used in sheet 2, this will return row 2 rather than row
'1, but in practice that may not matter.
'(I wouldn't be surprised if you want headings anyway.)
l_FreeRow = wks2.UsedRange.Row + wks2.UsedRange.Rows.Count

'Make sure that the row is not greater than the number
'of rows on the sheet.
If l_FreeRow > wks2.Rows.Count Then
    Err.Raise vbObjectError + 20000, , "No free rows on sheet " & wks2.Name
End If

'Set a range reference to the target.
'This will be the first free row, column 1 (column A).
Set rng_target = wks2.Cells(l_FreeRow, 1)

'Now copy the entire row that contains the e-mail address
'to the target that we identified above. Note that we DON'T need
'to select either the source range or the target range to do this; in fact
'doing so would just slow the code down.
rng_Found.EntireRow.Copy rng_target

'We always leave the procedure at this point so that we can clear
'all of the object variables (sheets, ranges, etc).
ExitPoint:

On Error Resume Next
Set rng_Found = Nothing
Set wks1 = Nothing
Set wks2 = Nothing
Set rng_target = Nothing
On Error GoTo 0

Exit Sub


ErrorHandler:

MsgBox "Error " & Err.Number & vbCrLf & Err.Description

Resume ExitPoint

End Sub
于 2012-11-22T19:43:38.330 に答える
1

セルの範囲の内容を調べ、特定の文字列 (この場合は "@") を含むセルの行をターゲット ワークブックの新しい行にコピーする次のコードをまとめました。

Dim srcWorkbook As Workbook
Dim destWorkbook As Workbook
Dim srcWorksheet As Worksheet
Dim destWorksheet As Worksheet
Dim SearchRange As Range
Dim destPath As String
Dim destname As String
Dim destsheet As String
Set srcWorkbook = ActiveWorkbook
Set srcWorksheet = ActiveSheet

destPath = "C:\test\"
destname = "dest.xlsm"
destsheet = "Sheet1"

'これを目的のワークブックに設定パス/ワークブック名​​/ワークシート名

On Error Resume Next
Set destWorkbook = Workbooks(destname)
If Err.Number <> 0 Then
    Err.Clear
    Set wbTarget = Workbooks.Open(destPath & destname)
    CloseIt = True
End If

'宛先のワークブックが閉じている場合に開きます

For Each c In Range("A1:A100").Cells

'この範囲を、メールをチェックするセルに設定します

If InStr(c, "@") > 0 Then

'SET THE CALCULATION FOR DETERMINING AN EMAIL ADDRESS HERE (現在は @ 記号のみをチェックします)

    c.EntireRow.Copy
    destWorkbook.Activate
    destWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1).EntireRow.Select

'これは、宛先シートの次の空の行を検索して選択します

Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    srcWorkbook.Activate
End If
Next

コードタグを台無しにしてしまった場合はお詫びします。私はこのサイトに不慣れです:)

于 2012-11-22T20:14:17.127 に答える
1

このコードは、同じワークブックでコピーを行うためにより簡単になるはずです。ワークブック間でも作業する必要がある場合に備えて、最後の回答をそこに残します:)

For Each c In Range("A1:A100").Cells
'SET THIS RANGE TO THE CELLS YOU WANT TO CHECK FOR EMAIL
If InStr(c, "@") > 0 Then
'SET THE CALCULATION FOR DETERMINING AN EMAIL ADDRESS HERE (Currently it just checks for an @ symbol)
c.EntireRow.Copy Destination:=ActiveWorkbook.Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next
于 2012-11-23T01:35:46.413 に答える