I managed to copy cell formats within the same sheet by using
Dim c As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
If c Then Exit Sub
c = True
f = Mid(Target.Formula, 2)
Range(f).Copy
Target.PasteSpecial xlPasteAllUsingSourceTheme
c = False
End Sub
But in another sheet, I use =INDEX(Sheet1!$I$1:$J$255,MATCH(A4,Sheet1!$F$1:$F$255,0),1) to get the value from Sheet1.
Now how can I copy the source format just like the cells in the same sheet would!?
I had tried everything in Google Search to no avail!
I even tried to make my own function and still failing to do so!!!
'(One variation)
Function CopyFrom(ByVal Cell)
Dim r As Range
Set r = Worksheets(Cell.Parent.Name).Range(Cell.address(External:=False))
CopyFrom = r.Value2
r.Copy
Application.Caller.PasteSpecial xlPasteAllUsingSourceTheme
End Function
I'm kind of at the end of my rope now!
Somebody PLEASE be so kind and teach me how to do it!
Much appreciated!!!
Assuming the cell you want to copy is A1 on sheet called "another sheet".
Assuming you want to paste in cell A1 on sheet called "Sheet1".
option explicit
dim wb as workbook
dim wsSource as worksheet, wsDest as worksheet
dim Target As Range
Sub test()
set wb = thisworkbook
set wsSource = wb.Sheets("another sheet")
set wsDest = wb.Sheets("Sheet1")
Set Target = wsDest.Range("A1")
wsSource.Range("A1").Copy
Target.PasteSpecial xlPasteAllUsingSourceTheme
End Sub
Related
I have my data on sheet 1 and my button macros on sheet 2. Basically when someone presses a button I want it to take a value in a cell in sheet 1 and populate the equivalent cell in sheet 2.
for example
Button 1 -> take value in sheet 1 cell A1 and put into sheet 2 cell A1
My current macro contains the actual value
Sub SelectCell()
Range("L4").Value = ("200")
Range("L5").Value = ("80")
End Sub
Clone Values
s - Source, d - Destination
The code is to be copied to a standard module e.g. Module1.
It is assumed that you have a button on the destination worksheet, and whatever range you select on it, after pressing the button, the values from the source worksheet will be copied over. Multi-area ranges (e.g. "A1,C3,E12") are also covered.
The Code
Option Explicit
Sub cloneValues()
Const sName As String = "Sheet1"
Const dName As String = "Sheet2"
Dim wb As Workbook: Set wb = ThisWorkbook
If TypeName(Selection) = "Range" Then
If Selection.Worksheet Is wb.Worksheets(dName) Then
Dim drg As Range
For Each drg In Selection.Areas
drg.Value = wb.Worksheets(sName).Range(drg.Address).Value
Next drg
End If
End If
End Sub
First you should set your worksheets that you dont need to write it anymore. I asigned Sheet1 to ws1 and sheet2 to ws2.
Sub copy()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
ws2.Range("L4").Value = ws1.Range("L4").Value
'Loop from A1 to A100 and copy the values to sheet2
For i = 1 To 100
ws2.Cells(i, 1).Value = ws1.Cells(i, 1).Value
Next
End Sub
I have a master sheet where I enter name in column "B" from cell "B4:B50000" and in column "E" from cell "E4:50000" now when cell value change in this range than first check whether it's unique value or not, if it's unique value than create new sheet in same workbook with that unique name
I also want to have drop down list where all unique value from range B4:B50000 and E4:E50000 auto suggest matching name
e.g. In cell B4 name written is salman now i am typing name in cell B5 and after writing sal,it should be suggesting unique names starting from sal
I have tried following code from my side but as I am beginner in VBA I got partial success only, kindly help to fix it up
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range, sh As Worksheet
With ActiveSheet
For Each c In .Range("B3:B50000", .Cells(Rows.Count, 1).End(xlUp))
Set sh = Sheets.Add(After:=Sheets(Sheets.Count))
sh.Name = c.Value
Set sh = Nothing
Next
End With
End Sub
Any help ll be appriciated, thx in advance.
Add a new worksheet for Unique values entered into Column B
Make sure the change event is only activated when change occurs in your target column (B) using Interest
Loop for each new value added to target column vs every item (what you are doing)
Use CountIf to isolate unique values
Check to make sure the sheet being added does not already exist (UDF from Tim Williams)
Private Sub Worksheet_Change(ByVal Target As Range)
Dim x As Range, ws As Worksheet
If Not Intersect(Target, Range("B:B")) Is Nothing Then
For Each x In Target
If Application.WorksheetFunction.CountIf(Range("B:B"), x) = 1 Then
If Not WorksheetExists(x.Value, ThisWorkbook) Then
Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
ws.Name = x.Value
Set ws = Nothing
Else
MsgBox "Worksheet Already Exists With Name '" & x.Value & "'", vbCritical
End If
End If
Next x
End If
End Sub
Function WorksheetExists(shtName As String, Optional wb As Workbook) As Boolean
Dim sht As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
WorksheetExists = Not sht Is Nothing
End Function
I have a workbook, with multiple sheets, which have comments. I have to loop through each of the sheets and pick up the comments. I have implemented the following logic.
For Each Ip_Sheet In ActiveWorkbook.Worksheets
Set Rng = Ip_Sheet.Cells.SpecialCells(xlCellTypeComments)
If Rng Is Nothing Then
MsgBox "No comments in the sheet"
Else
For Each cell In Rng
Comment_Author_NameAndComment = Split(cell.Comment.Text, ":")
AuthName = Comment_Author_NameAndComment(0)
AuthComments = Comment_Author_NameAndComment(1)
The above logic works fine if there are no merged cells in the worksheet. However, if there are merged cells/rows, the loop For Each cell In Rng runs for each of the cells in the merged cells range. For example, if columns A:D are merged, then the loop runs for each of the cells A, B, C and D and I get the same value in the AuthName and AuthComments variables.
My question is, how do I make the loop to skip to the next comment on the worksheet if I find a merged cell?
Edit:
I also tried to loop through all the comments in the sheet by the following method, however, the method was not successful - the Rng.Comment object was always empty.
For Each cmnt_obj In Rng.Comment
cmt_txt = cmnt_obj.Text
Next cmnt_obj
Since SpecialCells(xlCellTypeComments) returns all cells for a Merged Range, you need to detect when a cell is part of a named range and only process one of those cells. You can use Range.MergeCells to detect a merged cell, and Range.MergeArea to return the merged range itself. Then only report the comment if the cell is the Top Left cell of the merged range.
Something like this:
Sub Demo()
Dim rng As Range
Dim cl As Range
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
For Each ws In wb.Worksheets
Set rng = ws.Cells.SpecialCells(xlCellTypeComments)
If Not rng Is Nothing Then
For Each cl In rng.Cells
If cl.MergeCells Then
If cl.Address = cl.MergeArea.Cells(1).Address Then
ReportComment cl
End If
Else
ReportComment cl
End If
Next
End If
Next
End Sub
Sub ReportComment(cl As Range)
Dim Comment_Author_NameAndComment() As String
Dim AuthName As String
Dim AuthComments As String
Comment_Author_NameAndComment = Split(cl.Comment.Text, ":")
AuthName = Comment_Author_NameAndComment(0)
AuthComments = Comment_Author_NameAndComment(1)
Debug.Print AuthName, AuthComments
'...
End Sub
I have an excel sheet with the list of excel workbooks in a column and corresponding data in the other column. I want to be able to open each workbook and fill a particular column with the correspending data only. Currently, my code opens each workbook and append with data of other workbook below it.
My code:
Sub Workbook_Open()
Dim r1 As Range, r2 As Range, N As Long, r As Range, x As Range
Workbooks.Open "C:\Users\HP\Documents\test\script.xlsx"
For Each r In Range("A1:A3")
With r
Workbooks.Open r
Set Rng = Sheets("Sheet1").Range("B1:B3")
For Each cell In Rng
With cell
Set r2 = Sheets("Sheet1").Range("Y3:Y3")
Rng.Copy r2
End With
Next cell
End With
Next r
End Sub
Your input will be glady appreciated.
I don't really understand what you are copying but I assuming you want to open each file in column A of your master file, extract some cells from that file and place it in the cells to the right of column A. This transfers a couple of cells so hopefully you can work out how to amend to your needs, or come back if not.
Sub Workbook_Open()
Dim r1 As Range, rng As Range, N As Long, r As Range, x As Range, wbMaster As Workbook, wb As Workbook
Set wbMaster = Workbooks.Open("C:\Users\HP\Documents\test\script.xlsx")
For Each r In wbMaster.Sheets(1).Range("A1:A3")
Set wb = Workbooks.Open(r)
wb.Sheets("Sheet1").Range("B1").value=r.Offset(, 1).Value 'this fills B1 of the workbook opened with B of the master file
wb.close false
Next r
End Sub
I would really appreciate it if someone can help me with a VBA. Loop through multiple worksheet in same WorkBook and copy 1 column i.e. col B, and paste/append in the next blank column in the active worksheet.
Thanks,
Adil
There are some limitations here but this should get you started.
Sub copyColumn()
Dim wks As Worksheet
Set wks = ActiveSheet
'Source worksheet to copy from
Dim srcwk As Worksheet
Set scrwk = ActiveWorkbook.Worksheets(3)
'Copy range A1:A10 from source to active sheet in next open column
scrwk.Range("A1:A10").Copy wks.Range("IV1").End(xlToLeft).Offset(0, 1)
End Sub
Something like this?
Sub Move_Column()
CurrWS = ActiveSheet.Name
For each Sheet in ActiveWorkbook.Sheets
If Sheet.Name <> CurrWS Then
NextColumn = Sheets(CurrWS).Range("XFD1").End(xlToLeft).Column + 1
Sheets(CurrWS).Range(Sheets(CurrWS).Cells(1, NextColumn), Sheets(CurrWS).Cells(100, NextColumn)).Value = Sheet.Range(Sheet.Cells(1, 2), Sheet.Cells(100, 2)).Value
End if
Next
End Sub