Hey guys so I'm doing this code for the company where I work as a internship. I did some part of it with the help of people from this forum and others but the code is big and I cannot find a place or the piece of code needed to do what I asked for, and that fits my code I'm newbie by the way.
So I will explain the code IT will import from a target excel file and then paste in my main file, after that it will search in the main file for the data that is present in the column A and then copy the information that is linked to the names and paste it in the import sheet called (Status) so I wanted to put a delete duplications before searching the information in the main file.
Sorry for the Big code. Forgot to mentioned the files come duplicated from the source file but I cannot change the source file, probably is easier if the import doesn't take duplicated rows ?
So I will explain the code IT will import from a target excel file and then paste in my main file, after that it will search in the main file for the data that is present in the column A and then copy the information that is linked to the names and paste it in the import sheet called (Status) so I wanted to put a delete duplications before searching the information in the main file.
Sorry for the Big code. Forgot to mentioned the files come duplicated from the source file but I cannot change the source file, probably is easier if the import doesn't take duplicated rows ?
Code:
Sub ImportData()
Application.ScreenUpdating = False
Dim Path As String, Lstrw As Long
Dim SourceWb As Workbook
Dim TargetWb As Workbook
Path = "C:\Users\DZPH8SH\Desktop\Status 496 800 semana 12 2015.xls" 'Change this to your company workbook path
workbook path
Set SourceWb = Workbooks.Open(Path)
Set TargetWb = ThisWorkbook
Dim n As Integer, targetRow As Long
targetRow = 3
With SourceWb.Sheets(1)
Lstrw = .Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
.Range("M1:M" & Lstrw).AutoFilter Field:=1, Criteria1:="496"
.Application.Union(.Range("D2:D" & Lstrw), .Range("F2:F" & Lstrw), .Range("I2:I" & Lstrw), .Range("M2:M" & Lstrw)).Copy
TargetWb.Sheets(7).Cells(TargetWb.Sheets(7).Rows.Count, "A").End(xlUp)(2).PasteSpecial xlPasteValues
.ShowAllData
End With
With SourceWb.Sheets(2)
Lstrw = .Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
.Application.Union(.Range("D2:D" & Lstrw), .Range("F2:F" & Lstrw), .Range("I2:I" & Lstrw), .Range("M2:M" & Lstrw)).Copy
TargetWb.Sheets(7).Cells(TargetWb.Sheets(7).Rows.Count, "A").End(xlUp)(2).PasteSpecial xlPasteValues
End With
SourceWb.Close savechanges:=False
Application.ScreenUpdating = True
'====================================== Search in the main file code below
On Error Resume Next
Dim CurrWk As Worksheet
Dim wb As Workbook
Dim wk As Worksheet
Dim LRow As Integer
Dim myLRow As Integer
Dim myLCol As Integer
Dim F1 As Boolean
Dim f As Boolean
Set wb = ActiveWorkbook
Set CurrWk = wb.Sheets(7)
LRow = LastRow(CurrWk)
For r = 3 To LRow
f = False
For Each wk In wb.Worksheets
If wk.Name = "Status" Or wk.Name = "Gráfico_2015" Then GoTo abc 'Exit For
If wk.Visible = xlSheetHidden Then GoTo abc 'Exit For
myLRow = LastRow(wk)
myLCol = LastCol(wk)
For r1 = 3 To myLRow
For c1 = 1 To myLCol
If Trim(CurrWk.Cells(r, 1).Value) = Trim(wk.Cells(r1, c1).Value) Then
f = True
F1 = False
If wk.Name = "ÄA" Then
For I = 12 To 18
If wk.Cells(r1, I).Value = 1 Then
CurrWk.Cells(r, 6).Value = wk.Cells(2, I).Value
F1 = True
Exit For
End If
Next I
Else
For I = 14 To 20
If wk.Cells(r1, I).Value = 1 Then
CurrWk.Cells(r, 6).Value = wk.Cells(2, I).Value
F1 = True
Exit For
End If
Next I
End If
If F1 = False Then CurrWk.Cells(r, 6).Value = "Set de equipa diferente"
End If
Next c1
Next r1
'If f = True Then Exit For
abc:
Next wk
If f = False Then
CurrWk.Cells(r, 12).Value = "Não está presente no ficheiro"
End If
Next r
Set wk = Nothing
Set wb = Nothing
On Error GoTo 0
MsgBox "Finished"
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function