vba copiare dati in foglio, sostituire i valori di errore?

Ho due cartelle di lavoro:

Libro di lavoro A (foglio 2)

immettere qui la descrizione dell'immagine

Libro di lavoro B (foglio 1)

immettere qui la descrizione dell'immagine

Sto provando a copiare alcuni valori dalla cartella A e incollarli nella cartella B.

Essenzialmente in cui il nome del fornitore esiste nella colonna B della workbook A, raggruppando tutti i fornitori e copiando tutti gli elementi / each row per each fornitore nella cartella B.

Quindi la cartella B è effettivamente un elenco di elementi che tale fornitore offre.

I valori che copiamo includono la descrizione dalla colonna I, il fattore Pallet dalla colonna L, la dimensione del caso dalla colonna M, la quantità dalla colonna N e il numero di pallet da Colonna O.

I valori devono essere tutti copiati nella cartella di lavoro B tra il range A30 e J39. Ogni row su una cosa tipo di linea.

Il codice ha un paio di difetti.

Utilizziamo la colonna N, dalla cartella A in questo esempio.

Possiamo vedere che il nostro primo fornitore nell'elenco è Accrol. Questo copia tutti i valori bene – senza alcun problema.

immettere qui la descrizione dell'immagine

Tuttavia, a volte, non esiste un valore per il fattore di pallet, la dimensione del case ecc. In questo caso avrà TBC o #VALUE!

Indipendentemente, questi valori dovrebbero essere copiati anche nella cartella di lavoro B come sotto.

immettere qui la descrizione dell'immagine

Utilizzo quindi questa linea di codice per sostituire qualsiasi occorrenza di #VALUE con TBC (solo per rendere l'intera cosa sembrare un po 'più complessa).

Set rng = Range("D30:G39") rng.Select Set cell = Selection.Find(What:="#VALUE!", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) If cell Is Nothing Then 'do it something Else For Each cell In rng cell.value = "TBC" Next 'End For wStemplaTE.Range("A41").value = "Please fill in the pallet factor and case size accordingly. Please amend total volume if necessary to accommodate full pallets." End If rng.Select Set cell = Selection.Find(What:="TBC", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) If cell Is Nothing Then 'do it something Else wStemplaTE.Range("A41").value = "Please fill in the pallet factor and case size accordingly. Please amend total volume if necessary to accommodate full pallets." End If 

Tuttavia, esiste un valore in colunn N per Green Isle, tuttavia questo non si estende come il fornitore Accrol.

Invece mostra come TBC. Ma il TBC dovrebbe mostrare solo where non c'era un valore legittimo – solo where c'era già TBC o #VALUE!

Sono in una perdita per come mai questo sia.

Ecco il mio codice integer:

 Sub Create() 'On Error GoTo Message Application.DisplayAlerts = False Application.ScreenUpdating = False Dim WbMaster As Workbook Dim wbTemplate As Workbook Dim wStemplaTE As Worksheet Dim i As Long Dim LastRow As Long Dim rngToChk As Range Dim rngToFill As Range Dim rngToFill2 As Range Dim rngToFill3 As Range Dim rngToFill4 As Range Dim rngToFill5 As Range Dim rngToFill6 As Range Dim rngToFill7 As Range Dim rngToFill8 As Range Dim rngToFill9 As Range Dim rngToFil20 As Range Dim CompName As String Dim TreatedCompanies As String Dim FirstAddress As String '''Reference workbooks and worksheet Set WbMaster = ThisWorkbook '''Loop through Master Sheet to get company names With WbMaster.Sheets(2) LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row '''Run Loop on Master For i = 2 To LastRow '''Company name Set rngToChk = .Range("B" & i) CompName = rngToChk.value If InStr(1, TreatedCompanies, CompName) Or CompName = vbNullString Then '''Company already treated, not doing it again Else '''Open a new template Set wbTemplate = Workbooks.Open("G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\Templates\template.xlsx") Set wStemplaTE = wbTemplate.Sheets(1) '''Set Company Name to Template wStemplaTE.Range("C12").value = CompName wStemplaTE.Range("C13").value = rngToChk.Offset(, 1).value wStemplaTE.Range("C14").value = rngToChk.Offset(, 2).value wStemplaTE.Range("C15").value = rngToChk.Offset(, 3).value wStemplaTE.Range("C16").value = Application.UserName wStemplaTE.Range("C17").value = Now() wStemplaTE.Range("A20").value = "Announcement of Spot Buy Promotion - Week " & ThisWorkbook.Worksheets(1).Range("I8").value & " " & ThisWorkbook.Worksheets(1).Range("T8").value Dim strDate strDate = rngToChk.Offset(, 14).value wStemplaTE.Range("C25").value = "Week " & ThisWorkbook.Worksheets(1).Range("I8").value & ", " & ThisWorkbook.Worksheets(1).Range("T8").value & " - " & Format(strDate, "dddd, mmm dd, yyyy") 'Set Delivery Date wStemplaTE.Range("C26").value = "Week " & Format(rngToChk.Offset(, 15).value, "ww", vbMonday, vbFirstFourDays) & ", " & Format(rngToChk.Offset(, 15).value, "yyyy") & " - " & Format(rngToChk.Offset(, 15).value, "dddd, mmm dd, yyyy") '''Add it to to the list of treated companies TreatedCompanies = TreatedCompanies & "/" & CompName '''Define the 1st cell to fill on the template Set rngToFill = wStemplaTE.Range("A30") Set rngToFill2 = wStemplaTE.Range("B30") Set rngToFill3 = wStemplaTE.Range("C30") Set rngToFill4 = wStemplaTE.Range("D30") Set rngToFill5 = wStemplaTE.Range("E30") Set rngToFill6 = wStemplaTE.Range("F30") Set rngToFill7 = wStemplaTE.Range("G30") Set rngToFill8 = wStemplaTE.Range("C13") Set rngToFill9 = wStemplaTE.Range("C14") Set rngToFil20 = wStemplaTE.Range("C15") With .Columns(2) '''Define properly the Find method to find all Set rngToChk = .Find(What:=CompName, _ After:=rngToChk.Offset(-1, 0), _ LookIn:=xlValues, _ LookAt:=xlWhole, _ SearchOrder:=xlByColumns, _ SearchDirection:=xlNext, _ MatchCase:=False, _ SearchFormat:=False) '''If there is a result, keep looking with FindNext method If Not rngToChk Is Nothing Then FirstAddress = rngToChk.Address Do '''Transfer the cell value to the template rngToFill.value = rngToChk.Offset(, 7).value rngToFill2.value = rngToChk.Offset(, 8).value rngToFill3.value = rngToChk.Offset(, 9).value rngToFill4.value = rngToChk.Offset(, 10).value rngToFill5.value = rngToChk.Offset(, 11).value rngToFill6.value = rngToChk.Offset(, 12).value rngToFill7.value = rngToChk.Offset(, 13).value '''Go to next row on the template for next Transfer Set rngToFill = rngToFill.Offset(1, 0) Set rngToFill2 = rngToFill.Offset(0, 1) Set rngToFill3 = rngToFill.Offset(0, 2) Set rngToFill4 = rngToFill.Offset(0, 3) Set rngToFill5 = rngToFill.Offset(0, 4) Set rngToFill6 = rngToFill.Offset(0, 5) Set rngToFill7 = rngToFill.Offset(0, 6) '''Look until you find again the first result Set rngToChk = .FindNext(rngToChk) Loop While Not rngToChk Is Nothing And rngToChk.Address <> FirstAddress Else End If End With '.Columns(2) Set rng = Range("D30:G39") rng.Select Set cell = Selection.Find(What:="#VALUE!", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) If cell Is Nothing Then 'do it something Else For Each cell In rng cell.value = "TBC" Next 'End For wStemplaTE.Range("A41").value = "Please fill in the pallet factor and case size accordingly. Please amend total volume if necessary to accommodate full pallets." End If rng.Select Set cell = Selection.Find(What:="TBC", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) If cell Is Nothing Then 'do it something Else wStemplaTE.Range("A41").value = "Please fill in the pallet factor and case size accordingly. Please amend total volume if necessary to accommodate full pallets." End If 'Add Statement wStemplaTE.Range("A57").Formula = "=""2. To send an original sample case (including correct case) of the product destined for sale no"" & CHAR(10) & "" later than Tuesday (" & rngToChk.Offset(, 15).value - 7 & ").""" 'Remove uneeded announcement rows wStemplaTE.Range("A30:A39").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True On Error GoTo Message21 file = AlphaNumericOnly(CompName) wbTemplate.SaveCopyAs fileName:="G:\BUYING\Food Specials\2. Planning\3. Confirmation and Delivery\Announcements\Created Announcements\" & file & ".xlsx" wbTemplate.Close False End If Next i End With 'wbMaster.Sheets(2) Application.DisplayAlerts = True Application.ScreenUpdating = True Dim answer As Integer answer = MsgBox("Announcements Successfully Created." & vbNewLine & vbNewLine & "Would you like to view these now?", vbYesNo + vbQuestion, "Notice") If answer = vbYes Then Call List Else 'do nothing End If Exit Sub Message: wbTemplate.Close savechanges:=False MsgBox "One or more files are in use. Please make sure all Announcement files are closed and try again." Exit Sub Message21: MsgBox "One of the Announcement files is open. Unable to continue." End Sub Function AlphaNumericOnly(strSource As String) As String Dim i As Integer Dim strResult As String For i = 1 To Len(strSource) Select Case Asc(Mid(strSource, i, 1)) Case 48 To 57, 65 To 90, 97 To 122: 'include 32 if you want to include space strResult = strResult & Mid(strSource, i, 1) End Select Next AlphaNumericOnly = strResult End Function Function FindAll(SearchRange As Range, _ FindWhat As Variant, _ Optional LookIn As XlFindLookIn = xlValues, _ Optional LookAt As XlLookAt = xlWhole, _ Optional SearchOrder As XlSearchOrder = xlByRows, _ Optional MatchCase As Boolean = False, _ Optional BeginsWith As String = vbNullString, _ Optional EndsWith As String = vbNullString, _ Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range End Function 

per favore può qualcuno mi mostra where sto andando male con questo? Forse c'è un modo più intelligente per farlo?

Tutte le celle del range D30:G39 hanno un valore di TBC causa di questo ciclo:

 For Each cell In Rng cell.Value = "TBC" Next 

Suggerisci di validationre il number of pallets prima sostituendo questa row:

 rngToFill7.Value = rngToChk.Offset(, 13).Value 

con questo:

 rngToFill7.Value = WorksheetFunction.IfError(rngToChk.Offset(, 13).Value, "TBC") 

Applica lo stesso per qualsiasi altro field che potrebbe avere il valore di errore #VALUE!

Rimuovere anche \ riscrivere le seguenti righe:

 Set Rng = Range("D30:G39") Rng.Select Set cell = Selection.Find(What:="#VALUE!", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) If cell Is Nothing Then 'do it something Else For Each cell In Rng cell.Value = "TBC" Next 'End For wStemplaTE.Range("A41").Value = "Please fill in the pallet factor and case size accordingly. Please amend total volume if necessary to accommodate full pallets." End If Rng.Select Set cell = Selection.Find(What:="TBC", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) If cell Is Nothing Then 'do it something Else wStemplaTE.Range("A41").Value = "Please fill in the pallet factor and case size accordingly. Please amend total volume if necessary to accommodate full pallets." End If