VBA Excel - копирование строк на другой лист книги с условиями

Question

Новичок пытается смешивать и сопоставлять коды в книге Excel, которая настроена на запрос входа в систему и позволяет diff Id и PW видеть разные листы.

If Me.userid.Value = "admin" And Me.userpw.Value = "admin" Then 
MsgBox "Login Successful!", vbInformation, "Login Alert" 
MsgBox "Entry and use data with caution and exercise confidentiality at all times!", vbExclamation, "Critical Reminder" 

Unload Me 

Sheets("Summary Report View").Visible = True 
Sheets("Summary Report View").Select 
Sheets("Data Validation").Visible = True 
Sheets("Data Entry 1").Visible = True 
Sheets("Data Entry 2").Visible = True 
Sheets("Data Entry 3").Visible = True 

У меня эта проблема не в состоянии копировать данные из другой книги (конкретный рабочий лист называется 6-9months) эта книга, что я работаю в Ввод данных 1. Условие, чтобы забрать все строки с именем «Джон» в столбце I и вставьте в мой лист активной книги с именем «ввод данных 1». Я попытался активировать коды с помощью нажатия кнопки, чтобы выбрать все строки, но, похоже, не работает.

Confirmation = MsgBox("Are you sure to removal all contents? This is not reversible", vbYesNo, "Confirmation") 

    Select Case Confirmation 
    Case Is = vbYes 

    Sheets("Data Entry 2").Cells.ClearContents 
    MsgBox "Information removed", vbInformation, "Information" 

    Dim GCell As Range 
    Dim Txt$, MyPath$, MyWB$, MySheet$ 
    Dim myValue As String 
    Dim P As Integer, Q As Integer 
    Txt = "John" 

    MyPath = "C:\Users\gary.tham\Desktop\" 
    MyWB = "Book1.xlsx" 

    'MySheet = ActiveSheet.Name 

    Application.ScreenUpdating = False 

    Workbooks.Open Filename:=MyPath & MyWB 
    lastrow = ActiveSheet.Range("A" & Rows.Count).End(x1Up).Row 
    For i = 2 To lastrow 

    If Cells(i, 11) = txt Then 
    Range(Cells(i, 1), Cells(i, 13)).Select 
    Selection.Copy 
    P = Worksheets.Count 
    For Q = 1 To P 
    If ThisWorkbook.Worksheets(Q).Name = "Data Entry 2" Then 
    Worksheets("Data Entry 2").Select 
    ThisWorkbook.Worksheets(Q).Paste 
    End If 
    Next Q 
    End If 
    Next i 

    Case Is = vbNo 
    MsgBox "No Changes Made", vbInformation, "Information" 

    End Select 

Answer 1

Основная проблема с вашим кодом является то, что вы работаете с несколькими файлами Excel одновременно (1) файл, который вы открываете и поиск «Джон» и (2) текущий файл, из которого вызывается макрос и к которому мы импортируем данные. Тем не менее, ваш код не ссылается на два файла, а просто указывает на поиск «john» в ActiveSheet. Кроме того, вы не указываете VBA, в каком из двух файлов вы хотите найти текущий активный лист.

Итак, если вы работаете с несколькими файлами, вам следует конкретно обратиться ко всем и не просить VBA делать предположения, какой файл или какой лист или какая ячейка на листе, в каком файле вы имеете дело. Смущенный? Если бы VBA был бы человеком, то он, вероятно, тоже был бы сбит с толку. Тем не менее, VBA просто делает предположения, и вам остается задаться вопросом, почему код не делает то, что вы ожидаете от него. Следовательно, при работе с несколькими файлами, вы должны использовать следующие прямые ссылки и сказать VBA именно то, что вы хотите (!):

Workbooks("Book1.xlsx").Worksheets("Sheet1").Cells(1, 1).Value2

или

Workbooks("Book1.xlsx").Worksheets("Sheet1").Range("A1").Value2

Сказав, что я изменил ваш код, чтобы использовать вышеизложенное.

Option Explicit 

Sub CopyDataFromAnotherFileIfSearchTextIsFound() 

Dim strPath As String 
Dim wbkImportFile As Workbook 
Dim shtThisSheet As Worksheet 
Dim shtImportSheet As Worksheet 

Dim lngrow As Long 
Dim strSearchString As String 
Dim strImportFile As String 

'uPPer or lOwEr cases do not matter (as it is currently setup) 
strSearchString = "jOHn" 
strImportFile = "Book1.xlsx" 

Set shtThisSheet = ThisWorkbook.Worksheets("Data Entry 2") 
'If the import file is in the same folder as the current file 
' then you could also use the following instead 
'strPath = ThisWorkbook.Path 
strPath = "C:\tmp" '"C:Users\gary.tham\Desktop" 

With Application 
    .ScreenUpdating = False 
    .Calculation = xlCalculationManual 
    .EnableEvents = False 
End With 

Set wbkImportFile = Workbooks.Open(Filename:=strPath & "\" & strImportFile) 
'To speed up things you could also (if acceptable) open the file 
' read-only without updating links to other Excel files (if there are any): 
'Set wbkImportFile = Workbooks.Open(Filename:=strPath & "\" & strImportFile, ReadOnly:=True, UpdateLinks:=False) 
Set shtImportSheet = wbkImportFile.Worksheets("6-9months") 

shtThisSheet.Cells.ClearContents 
For lngrow = 2 To shtImportSheet.Cells(shtImportSheet.Rows.Count, "I").End(xlUp).Row 
    If InStr(1, shtImportSheet.Cells(lngrow, "I").Value2, strSearchString, vbTextCompare) > 0 Then 
     shtImportSheet.Range(shtImportSheet.Cells(lngrow, 1), shtImportSheet.Cells(lngrow, 13)).Copy 
     shtThisSheet.Range("A" & shtThisSheet.Cells(shtThisSheet.Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteAll, xlPasteSpecialOperationNone 
    End If 
Next lngrow 

wbkImportFile.Close SaveChanges:=False 

With Application 
    .ScreenUpdating = True 
    .Calculation = xlCalculationAutomatic 
    .EnableEvents = True 
End With 

End Sub 

Обратите внимание, что вышеуказанный код не является точной копией. Возможны два изменения:

(1) Лист «Ввод данных 2» в текущем файле (файл, который вы импортируете) будет очищен без запроса пользователя.

(2) Лист «Ввод данных 2» напрямую ссылается без вышеуказанной проверки: если на самом деле есть лист по этому имени в текущем файле.

Итак, не забудьте внести соответствующие корректировки в соответствии с вашими потребностями.

Сообщите мне, если это решение работает для вас или у вас есть еще вопросы.