baskar5353
Board Regular
- Joined
- Mar 21, 2015
- Messages
- 114
hi,
i having "header" workbook. in that i'm having 5 header. i want to copy the data from another sheet based on this header.
if the header didnt match means i need pop up message box as header not match.
this my code:
Sub working_file()
Dim shtImport As Worksheet, shtMain As Worksheet
Dim c As Range, f As Range
Dim rngCopy As Range, rngCopyTo
MsgBox "Open Header file"
strFileToOpen = Application.GetOpenFilename _
(Title:="Please choose a file to open", _
FileFilter:="Excel Files *.xls* (*.xls*),")
Workbooks.Open Filename:=strFileToOpen
Rows("2:" & Rows.Count).ClearContents
Dim shtImport As Worksheet, shtMain As Worksheet
Dim c As Range, f As Range
Dim rngCopy As Range, rngCopyTo
MsgBox "Open Avance Msytery Shopper Trimestre aseguramiento"
strFileToOpen = Application.GetOpenFilename _
(Title:="Please choose a file to open", _
FileFilter:="Excel Files *.xls* (*.xls*),")
Workbooks.Open Filename:=strFileToOpen
Set shtImport = ActiveSheet ' "import" - could be different workbook
Windows("Header").Activate
Set shtMain = ActiveWorkbook.Sheets("New sheet")
For Each c In Application.Intersect(shtImport.UsedRange, shtImport.Rows(1))
'only copy if >1 value in this column (ie. not just the header)
If Len(c.Value) > 0 And Application.CountA(c.EntireColumn) > 1 Then
Set f = shtMain.Rows(1).Find(what:=c.Value, LookIn:=xlValues, _
LookAt:=xlWhole)
If Not f Is Nothing Then
Set rngCopy = shtImport.Range(c.Offset(1, 0), _
shtImport.Cells(Rows.Count, c.Column).End(xlUp))
Set rngCopyTo = shtMain.Cells(Rows.Count, _
f.Column).End(xlUp).Offset(1, 0)
'copy values
rngCopyTo.Resize(rngCopy.Rows.Count, 1).Value = rngCopy.Value
End If
End If
Next c
End Sub
in this code where i need to change for message box if header is not match means
i having "header" workbook. in that i'm having 5 header. i want to copy the data from another sheet based on this header.
if the header didnt match means i need pop up message box as header not match.
this my code:
Sub working_file()
Dim shtImport As Worksheet, shtMain As Worksheet
Dim c As Range, f As Range
Dim rngCopy As Range, rngCopyTo
MsgBox "Open Header file"
strFileToOpen = Application.GetOpenFilename _
(Title:="Please choose a file to open", _
FileFilter:="Excel Files *.xls* (*.xls*),")
Workbooks.Open Filename:=strFileToOpen
Rows("2:" & Rows.Count).ClearContents
Dim shtImport As Worksheet, shtMain As Worksheet
Dim c As Range, f As Range
Dim rngCopy As Range, rngCopyTo
MsgBox "Open Avance Msytery Shopper Trimestre aseguramiento"
strFileToOpen = Application.GetOpenFilename _
(Title:="Please choose a file to open", _
FileFilter:="Excel Files *.xls* (*.xls*),")
Workbooks.Open Filename:=strFileToOpen
Set shtImport = ActiveSheet ' "import" - could be different workbook
Windows("Header").Activate
Set shtMain = ActiveWorkbook.Sheets("New sheet")
For Each c In Application.Intersect(shtImport.UsedRange, shtImport.Rows(1))
'only copy if >1 value in this column (ie. not just the header)
If Len(c.Value) > 0 And Application.CountA(c.EntireColumn) > 1 Then
Set f = shtMain.Rows(1).Find(what:=c.Value, LookIn:=xlValues, _
LookAt:=xlWhole)
If Not f Is Nothing Then
Set rngCopy = shtImport.Range(c.Offset(1, 0), _
shtImport.Cells(Rows.Count, c.Column).End(xlUp))
Set rngCopyTo = shtMain.Cells(Rows.Count, _
f.Column).End(xlUp).Offset(1, 0)
'copy values
rngCopyTo.Resize(rngCopy.Rows.Count, 1).Value = rngCopy.Value
End If
End If
Next c
End Sub
in this code where i need to change for message box if header is not match means