Hi Dear,
Paste this code in to your workbook module and run *FillwithSource
procedure.*
*Sub FillWithSource()*
*
*
* Dim wksSht As Worksheet*
* Dim rngRange As Range*
* Dim rngCell As Range*
* Dim rngData As Range*
* Dim strHead() As Variant*
* *
* Const strDestiRange As String = "A9:A108"*
* Const strSourceRange As String = "B9:B108"*
* Const strFinalResultCell As String = "E8"*
* Const intTotalDataColumn As Integer = 2*
* Const strCommentText As String = "Old File"*
* *
* For Each wksSht In ThisWorkbook.Worksheets*
* With wksSht*
* strHead = Array("Old", "New")*
* .Range(strFinalResultCell).Offset(1).FormulaArray =
"=COUNT((N((" & strSourceRange & ")<>"""")))"*
* If .Range(strFinalResultCell).Offset(1).Value > 0 Then*
* On Error Resume Next*
* Set rngData =
.Range(strFinalResultCell).Offset(1).Resize(.Range(strDestiRange).Rows.Count)
*
* With rngData.Resize(, intTotalDataColumn)*
* .Clear*
* End With*
* .Range(strFinalResultCell).Resize(LBound(strHead) + 1,
UBound(strHead) + 1).Value = strHead*
* rngData.Resize(, intTotalDataColumn).Value =
.Range(strDestiRange).Resize(, intTotalDataColumn).Value*
* Set rngRange = Nothing*
* Set rngRange = rngData.SpecialCells(xlCellTypeBlanks)*
* rngRange.FormulaR1C1 = "=RC[1]"*
* strHead = rngData.Value*
* Set rngRange = subractRanges(rngData, rngRange)*
* If Not rngRange Is Nothing Then*
* For Each rngCell In rngRange*
* With rngCell*
* .ClearComments*
* .AddComment*
* .Comment.Text Text:=strCommentText*
* End With*
* Next rngCell*
* End If*
* On Error GoTo 0: Err.Clear*
* rngData.Value = strHead*
* rngData.Offset(, 1).ClearContents*
* End If*
* End With*
* Next wksSht*
* *
* Set wksSht = Nothing*
* Set rngRange = Nothing*
* Set rngCell = Nothing*
* Set rngData = Nothing*
* Erase strHead*
* *
*End Sub*
*
*
*Function subractRanges(subtractee As Range, subtractor As Range) As Range*
*
*
* Dim rngFinal As Range*
* *
* For Each rngFinal In subtractee*
* If Intersect(rngFinal, subtractor) Is Nothing Then*
* If subractRanges Is Nothing Then*
* Set subractRanges = rngFinal*
* Else*
* Set subractRanges = Union(subractRanges, rngFinal)*
* End If*
* End If*
* Next rngFinal*
* *
* Set rngFinal = Nothing*
*End Function*
Regards,
Lalit Mohan
On Friday, 4 January 2013 21:59:30 UTC+5:30, Best Of Luck wrote:
>
> I am attaching the file MacroText.xlsm Sheet one has more explaination.
> thanks again
>
>
> On Thursday, January 3, 2013 10:41:49 PM UTC-6, Lalit Mohan Pandey wrote:
>
>> Hi Dear,
>>
>> Can you please share it again with the output or result you want to see
>> for better clearity.
>>
>> Regards,
>> Lalit Mohan
>>
>> On Friday, 4 January 2013 01:18:39 UTC+5:30, Best Of Luck wrote:
>>>
>>> Lalit
>>>
>>> thanks for the macro. I am loading an example sheet for you . I need to
>>> run it for each activesheet using a button on a form.
>>>
>>>
>>>
>>>
>>> On Thursday, January 3, 2013 4:47:27 AM UTC-6, Lalit Mohan Pandey wrote:
>>>
>>>> Hi Dear,
>>>>
>>>> May be blow code will work as i understand but for better clearity
>>>> share sample workbook.
>>>>
>>>> *Sub FillWithSource()*
>>>> *
>>>> *
>>>> * Dim wksSht As Worksheet*
>>>> * Dim rngRange As Range*
>>>> * *
>>>> * Const strSourceRange As String = "B1:B19"*
>>>> * Const strDestiRange As String = "A1:A19"*
>>>> * *
>>>> * For Each wksSht In ThisWorkbook.Worksheets*
>>>> * With wksSht*
>>>> * If WorksheetFunction.Count(.Range(strSourceRange)) > 0
>>>> Then*
>>>> * On Error Resume Next*
>>>> * Set rngRange = Nothing*
>>>> * Set rngRange =
>>>> .Range(strDestiRange).SpecialCells(xlCellTypeBlanks)*
>>>> * rngRange.FormulaR1C1 = "=RC[1]"*
>>>> * On Error GoTo 0: Err.Clear*
>>>> * .Range(strSourceRange).ClearContents*
>>>> * End If*
>>>> * End With*
>>>> * Next wksSht*
>>>> * *
>>>> *End Sub*
>>>> *
>>>> *
>>>> *Regards,*
>>>> *Lalit Mohan*
>>>>
>>>> On Thursday, 3 January 2013 14:23:00 UTC+5:30, Best Of Luck wrote:
>>>>>
>>>>> hi,
>>>>> Happy new year,
>>>>>
>>>>> I need a macro that would copy cells based upon values in other
>>>>> cells. I am using Excel 10.
>>>>> I have a worksbook that has about 20 worksheets in it. Each of these
>>>>> worksheets has 2 columns A8:A108 & B8:B108.. I want a macro that would do
>>>>> the following:
>>>>>
>>>>> 1. Select the activesheet & read the values in the source columns
>>>>> B8:B108 and if there are no corrosponding values in the target columns
>>>>> A8:A108 to copy cells from the source B8:B108 to target A8:A108
>>>>> and
>>>>> clear the contents of source cells B8:B108 .
>>>>> 2. But if there are values in the target cells A8:A108 to leave
>>>>> the values in those cells alone and still clear the contents of
>>>>> source
>>>>> cells B8:B108 but Insert a comment saying "Old File" in the
>>>>> corrosponding
>>>>> target cells A8:A108 .
>>>>>
>>>>>
>>>>>
>>>>> Both source cells B8:B108 & target cells A8:A108 are formated as
>>>>> text,
>>>>>
>>>>> thanks...
>>>>>
>>>>
--
Join official Facebook page of this forum @
https://www.facebook.com/discussexcel
FORUM RULES
1) Use concise, accurate thread titles. Poor thread titles, like Please Help,
Urgent, Need Help, Formula Problem, Code Problem, and Need Advice will not get
quick attention or may not be answered.
2) Don't post a question in the thread of another member.
3) Don't post questions regarding breaking or bypassing any security measure.
4) Acknowledge the responses you receive, good or bad.
5) Jobs posting is not allowed.
6) Sharing copyrighted material and their links is not allowed.
NOTE : Don't ever post confidential data in a workbook. Forum owners and
members are not responsible for any loss.
---
You received this message because you are subscribed to the Google Groups "MS
EXCEL AND VBA MACROS" group.
To post to this group, send email to excel-macros@googlegroups.com.
To unsubscribe from this group, send email to
excel-macros+unsubscr...@googlegroups.com.
Visit this group at http://groups.google.com/group/excel-macros?hl=en.
