Below is the code which I came up to get all the source formating whenever I require a vlookup type operation in excel. I am also getting any formulas by this way. If there is a way to elimate the formula and get only the value and formating then it will be of great help.
Option Explicit
Sub finding()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Worksheets("Sheet2")
Dim i As Integer
Dim FoundRange As Range
Dim sFoundRange As String
Dim range_to_copy As Range
Dim range_to_paste As Range
Dim ToFindString As String
For i = 2 To 9
ToFindString = ws.Cells(i, 1)
On Error Resume Next:
sFoundRange = ws1.Range("E1:E12").Find(ToFindString).Address
Debug.Print sFoundRange
Set range_to_copy = ws1.Range(Replace(sFoundRange, "E", "F"))
Set range_to_paste = ws.Range("B" & i)
range_to_copy.Copy
range_to_paste.PasteSpecial xlPasteAllUsingSourceTheme
Application.CutCopyMode = False
Next i
End Sub
In order to check if a cell contains a formula, you might use the worksheet function =FormulaText(). I did a test with the Formula property of a range, but this did not work. (Maybe you might check if the first character is a = sign)
Related
Function StripChar(Txt As String) As String
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "\D"
StripChar = .Replace(Txt, "")
End With
End Function
So i am trying to apply this function on bottom range via loop through cells
Sub Alphabetremove()
Dim ws As Worksheet
Dim Lastrow As Integer
Set ws = ActiveSheet
Lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Range("F2:F" & Lastrow).Select
With Selection
.Value = StripChar(.Value)
End With
End Sub
The issue is that you cannot run the function .Value = StripChar(.Value) on a range at once (as you tried) but only on a single cell. Therfore you need to loop from row 2 to LastRow and apply the function to each single cell.
Also note that row counting variables need to be of type Long because Excel has more rows than Integer can handle. Actually I recommend always to use Long instead of Integer as there is no benefit in using Integer in VBA.
Also if you set your worksheet to a variable ws you need to use this variable for all .Cells and .Range objects otherwise this is useless.
Option Explicit
Public Sub Alphabetremove()
Dim ws As Worksheet
Set ws = ActiveSheet 'better define a workseet by name unless you use the code for multiple worksheets:
'Set ws = ThisWorkbook.Worksheets("MySheet")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Dim Cell As Range
For Each Cell In ws.Range("F2:F" & LastRow)
Cell.Value = StripChar(Cell.Value)
Next Cell
End Sub
Finally I highly recommend you to read How to avoid using Select in Excel VBA and apply this to all of your code.
I'm working with two workbooks. In the first I search for the value in the cell to the right of "Charge Number". Take that value and search the second workbooks pivot table for the matching row, copy it and go back to first work book and paste the data. This works great once. But I'm unable to get a loop to look for the next instance of "Charge Number" and repeat the process. The loop I have in the code isn't right because it finds the first value fine but then searches every next row for the same Charge Number.
Sub FindChargeNo()
Dim Loc As Range
Dim ChgNum As String
Dim SrchRng2 As String
Dim pvt As PivotTable
Dim wb As Workbook, ws As Worksheet
Dim FstWB As Workbook
Dim SecWB As Workbook
Dim rng As Range
Set FstWB = Workbooks("First.xlsm")
Set SecWB = Workbooks("Second_test.xlsx")
Set ws1 = FstWB.Worksheets("New Development")
Set ws = SecWB.Worksheets("Aug 18 Report")
Set pvt = ws.PivotTables(1)
lastRow = FstWB.Worksheets("New Development").Range("J" & Rows.Count).End(xlUp).Row
For i = 1 To lastRow
Set Loc = ws1.Cells.Find(What:="Charge Number")
If Not Loc Is Nothing Then
ChgNum = Loc.Offset(0, 1).Value
Debug.Print ChgNum
Debug.Print SrchRng
With pvt.PivotFields("Project WBS").PivotItems(ChgNum).LabelRange
Set rng = ws.Range(.Resize(.Rows.Count, pvt.TableRange1.Columns.Count).Address)
ws.Range(rng.Address).Copy
End With
SrchRng2 = Loc.Offset(0, 5).Address
FstWB.Worksheets("New Development").Range(SrchRng2).PasteSpecial
Set Loc = ws1.Cells.FindNext(Loc)
Loop While Loc.Address <> firstAddress
End If
Next
End Sub
I am trying to create a UDF using the SUMPRODUCT function which will reference data in an external closed workbook and return a value based on a couple of different criteria.
The reason I am tyring to do this is because some of the formula in the file while using the SUMPRODUCT feature could end up quite long.
So far I have come up with the following and appear to be just getting a #value error returning.
Public Function ReceiptTotal(Criteria1 As Variant, Criteria2 As Variant, Criteria3 As Variant) As Variant
Dim wbk As Workbook
Dim wks As Worksheet
Dim Criteria1Column As Range
Dim Criteria2Column As Range
Dim Criteria3Column As Range
Dim ResultColumn As Range
Dim LastRow As Long
Set wbk = Workbooks("J:\Users\Sarah\New Cash Sheet Ideas\[Receipt Log Test.xlsm]")
Set wks = wbk.Worksheets("1819")
With wbk
With wks
LastRow = wbk.wks.Range("A" & Rows.Count).End(xlUp).Row
Set Criteria1Column = wbk.wks.Range("E5:E" & LastRow) 'Criteria1Column = Bank Account
Set Criteria2Column = wbk.wks.Range("F5:F" & LastRow) 'Criteria2Column = Receipt Type
Set Criteria3Column = wbk.wks.Range("J5:J" & LastRow) 'Criteria3Column = Date
Set ResultColumn = wbk.wks.Range("H5:H" & LastRow) 'ResultColumn = Receipt Value
ReceiptTotal = [SUMPRODUCT((ResultColumn) * (Criteria1Column = Criteria1) * (CriteriaColumn2 = Criteria2) * (CriteriaColumn3 = Criteria3)]
End With
End With
End Function
I would really appreciate if someone can advise where I am going wrong.
I have written the following code to create worksheet with names same as the names in first column of Sheet1
I am getting a TypeError when trying to set the name on the new worksheet but don't know why. Can someone help?
Sub CreateWorkSheets()
'
' Macro5 Macro
'
'
Dim r As Range
Set r = Sheets("Sheet1").Columns(1)
For Each cell In r
Dim aa As String
Dim newSheet As Worksheet
Set newSheet = Sheets.Add(After:=Sheets(Sheets.Count))
strTemp = cell.Value
newSheet.Name = strTemp // Error Here
Next cell
End Sub
I tried the following code as well and that doesn't work either even though strValue is valid
Sub Test1()
Sheets("Sheet1").Select
Dim x As Integer
' Set numrows = number of rows of data.
NumRows = Range("A2", Range("A2").End(xlDown)).rows.Count
' Select cell a1.
Range("A2").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
Dim newSheet As Worksheet
Set newSheet = Sheets.Add(After:=Sheets(Sheets.Count))
Sheets("Sheet1").Range("B1").Value = "A" + Trim(Str(x))
strValue = "A" + Trim(Str(x))
newSheet.Name = Str(Sheets("Sheet1").Range(strValue).Value)
Next
End Sub
Apparently because you set:
Set r = Sheets("Sheet1").Columns(1)
It set the cell object to column $A:$A instead of $A$1 like you would think. I put this in the immediate window when I ran into the "cell.value" line:
?cell.Address
$A:$A
You should avoid using an entire column to do what you're trying to do and I would highly recommend you add these keywords to the top of your module:
Option Explicit
This will check your code a little more thoroughly and help you avoid unwanted errors.
To fix this, you can get the exact range you need and I recommend you declare every variable so it stays a specific type.
Something like this:
Option Explicit
Sub CreateWorkSheets()
Dim r As Range
Dim sh As Worksheet
Dim tempSh As Worksheet
Dim cell As Range
Dim strTemp As String
Set sh = Sheets("Sheet1")
Set r = sh.Range(sh.Cells(1, 1), sh.Cells(sh.Rows.Count, 1).End(xlUp))
For Each cell In r
Set tempSh = Sheets.Add(After:=Sheets(Sheets.Count))
strTemp = cell.Value
tempSh.Name = strTemp '// no more error
Next cell
End Sub
https://dl.dropbox.com/u/3327208/Excel/copydown.xlsx
This is the sheet if you can't view dropbox.
This is the workbook. What I'm looking to do is where it shows 3M, copy the title of the company down to where it shows Total in Column A, and do the same with the next company.
How do I do this in Excel VBA? I know I can use the last row, but it's not exactly the best way for this I believe, because the original version will have over 300 different companies.
Here is the original code I am using for now. Without the extra bits added in.
Option Explicit
Sub Import()
Dim lastrow As Long
Dim wsIMP As Worksheet 'Import
Dim wsTOT As Worksheet 'Total
Dim wsSHI As Worksheet 'Shipped
Dim wsEST As Worksheet 'Estimate
Dim wsISS As Worksheet 'Issued
Dim Shift As Range
Set wsIMP = Sheets("Import")
Set wsTOT = Sheets("Total")
Set wsSHI = Sheets("Shipped")
Set wsEST = Sheets("Estimate")
Set wsISS = Sheets("Issued")
With wsIMP
wsIMP.Range("E6").Cut wsIMP.Range("E5")
wsIMP.Range("B7:G7").Delete xlShiftUp
End Sub
Matt, I had a great function for this a few months back, but I forgot to copy into my library. However, I've done a pretty good mock-up of what I had before. (I was using it to fill down entries in a pivot table for some reason or other).
Anyway, here it is. You may need to tweak it to meet your exact needs, and I am not claiming it's not prone to any errors at the moment, but it should be a great start.
EDIT = I've updated my code post to integrate into yours to make it easier for you.
Sub Import()
Dim lastrow As Long
Dim wsIMP As Worksheet, wsTOT As Worksheet 'Total
Dim wsSHI As Worksheet, wsEST As Worksheet 'Estimate
Dim wsISS As Worksheet, Shift As Range
Set wsIMP = Sheets("Import")
Set wsTOT = Sheets("Total")
Set wsSHI = Sheets("Shipped")
Set wsEST = Sheets("Estimate")
Set wsISS = Sheets("Issued")
With wsIMP
.Range("E6").Cut .Range("E5")
.Range("B7:G7").Delete xlShiftUp
Call FillDown(.Range("A1"), "B")
'-> more code here
End With
End Sub
Sub FillDown(begRng As Range, col As String)
Dim rowLast As Long, rngStart As Range, rngEnd As Range
rowLast = Range(col & Rows.Count).End(xlUp).Row
Set rngStart = begRng
Do
If rngStart.End(xlDown).Row < rowLast Then
Set rngEnd = rngStart.End(xlDown).Offset(-1)
Else
Set rngEnd = Cells(rowLast, rngStart.Column)
End If
Range(rngStart, rngEnd).FillDown
Set rngStart = rngStart.End(xlDown)
Loop Until rngStart.Row = rowLast
End Sub
enter code here
As long as there are no formulas you don't want to overwrite...
EDIT - updated to set original range based off end of column B
Sub Macro1()
Dim sht as WorkSheet
Set sht = ActiveSheet
With sht.Range(sht.Range("A7"), _
sht.Cells(Rows.Count, 2).End(xlUp).Offset(0, -1))
.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
.Value = .Value
End With
End Sub