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
Related
I'm trying to take a part number from one sheet, find it in another sheet, then for the cells that correspond to tomorrow's date copy the quantity of parts for that specific part number plus two weeks out which is the resize. The code is starting to get really messy and I'm getting confused as to why it's not working. Currently I'm getting an error on cilrow = cil.rows with a mismatch.
Dim cel As Range
Dim cul As Range
Dim cil As Range
Dim cilrow As Long
Dim culcol As Long
Dim wkbOrig As Workbook
Dim wkbShape As Workbook
Dim shtShape As Worksheet
Set wkbOrig = ThisWorkbook
Set wkbShape = Workbooks("SHAPE Detailed coverage tracking WK" & WorksheetFunction.IsoWeekNum(Date))
Set shtShape = wkbShape.Worksheets("Detail coverage tracking")
For Each cel In wkbOrig.Sheets(2).Range("C3:C4,C9:C14")
For Each cil In shtShape.Range("H6:H11")
If Left(cel, 10) = cil.Value Then
cilrow = cil.Rows
For Each cul In shtShape.Range("5:5")
If cul.Value = Date + 1 Then
culcol = cul.Column
Range(Cells(cilrow, culcol)).Resize(, 14).Copy
End If
Next
End If
Next
Next
You can do less looping if you use Match().
Untested:
Sub Tester()
Dim cel As Range, wkbShape As Workbook, shtShape As Worksheet
Dim wkbOrig As Workbook, dateCol As Variant, matchRow As Variant
Dim rngSrch As Range
Set wkbOrig = ThisWorkbook
'best to include the file extension in the workbook name...
Set wkbShape = Workbooks("SHAPE Detailed coverage tracking WK" & _
WorksheetFunction.IsoWeekNum(Date))
Set shtShape = wkbShape.Worksheets("Detail coverage tracking")
'try to match the date...
dateCol = Application.Match(CLng(Date + 1), shtShape.Rows(5), 0)
If IsError(dateCol) Then 'date not matched?
MsgBox "Tomorrow's date not found on Row6 of " & shtShape.Name, vbExclamation
Exit Sub
End If
Set rngSrch = shtShape.Range("H6:H11")
For Each cel In wkbOrig.Sheets(2).Range("C3:C4,C9:C14").Cells
matchRow = Application.Match(Left(cel.Value, 10), rngSrch, 0)
If Not IsError(matchRow) Then
rngSrch.Cells(matchRow).EntireRow.Cells(dateCol).Resize(1, 14).Copy 'to where ?
End If
Next
End Sub
I have a worksheet where Appt Note text is very lengthy. I need to place it in a row of nine merged cells.
I'm trying to check all the cells in column A for the value "Appt Note:" then merge the nine cells to the right of it so all my data shows up in a viewable format.
I checked lots of posts online but can't put my particular code together. I've built it, with the exception of the merge.
Sub MergeTest()
Dim cel As Range
Dim WS As Worksheet
For Each WS In Worksheets
For Each cel In WS.Range("$A1:$A15")
If InStr(1, cel.Value, "Appt Note:") > 0 Then Range(cel.Offset(1, 9)).Merge
Next
Next
End Sub
As per my comment, hereby a sample of Range.Find where in this case I assume "Appt Note:" only exists once per sheet:
Sub Test()
Dim ws As Worksheet
Dim cl As Range
For Each ws In ThisWorkbook.Worksheets
Set cl = ws.Range("A:A").Find(What:="Appt Note:", Lookat:=xlPart)
If Not cl Is Nothing Then
cl.Offset(0, 1).Resize(1, 9).Merge
End If
Next
End Sub
Note: Merged cells are VBA's worst nightmare! Try to stay away from them. Maybe you can let the text just overflow?
Edit: In case your value could exist multiple times, use Range.FindNext:
Sub Test()
Dim ws As Worksheet
Dim cl As Range
Dim rw As Long
For Each ws In ThisWorkbook.Worksheets
Set cl = ws.Range("A:A").Find(What:="Appt Note:", Lookat:=xlPart)
If Not cl Is Nothing Then
rw = cl.Row
Do
cl.Offset(0, 1).Resize(1, 9).Merge
Set cl = ws.Range("A:A").FindNext(cl)
If cl Is Nothing Then
GoTo DoneFinding
End If
Loop While cl.Row <> rw
End If
DoneFinding:
Next
End Sub
Sub MergeTest()
Dim ws As Worksheet, cell As Range
For Each ws In ThisWorkbook.Worksheets
For Each cell In ws.Range("A1:A15")
If cell.Value Like "Appt Note:*" Then cell.Resize(1, 9).Merge
Next
Next
End Sub
ThisWorkbook refers to the workbook where the VBA code is, to avoid issues when a different workbook is active. The Like operator can be used to check if the cell value matches a wildcard pattern.
cell.Resize(1, 9) can be used to get a new range starting from cell and resized to 9 columns.
I found code that will do what I need. See below. I've tested it and it works. It will start at the bottom of my spreadsheet and find the last row with data and work it's way up until it reaches my first row.
Thanks so much for all your help! If you have any suggestions, advice, warnings, etc regarding the code below, please share. As I said, I am completely new to VB and know just enough to be dangerous. So I can use all the help I can get. :)
Sub mergeCellsBasedOnCriteria()
Dim myFirstRow As Long
Dim myLastRow As Long
Dim myCriteriaColumn As Long
Dim myFirstColumn As Long
Dim myLastColumn As Long
Dim myWorksheet As Worksheet
Dim myCriteria As String
Dim iCounter As Long
myFirstRow = 1
myCriteriaColumn = 1
myFirstColumn = 2
myLastColumn = 10
myCriteria = "Appt Note:"
Set myWorksheet = Worksheets("Sample")
With myWorksheet
myLastRow = .Cells.Find(What:="*", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For iCounter = myLastRow To myFirstRow Step -1
If .Cells(iCounter, myCriteriaColumn).Value = myCriteria Then
.Range(.Cells(iCounter, myFirstColumn), .Cells(iCounter, myLastColumn)).Merge
.Range(.Cells(iCounter, myFirstColumn), .Cells(iCounter, myLastColumn)).WrapText = True
End If
Next iCounter
End With
End Sub
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)
I am looking for a code to get the name of the last added sheet to Excel.
I have tried this...
Sub test()
Dim lastAddedSheet As Worksheet
Dim oneSheet As Worksheet
With ThisWorkbook
Set lastAddedSheet = .Sheets(1)
For Each oneSheet In .Sheets
If Val(Mid(oneSheet.CodeName, 6)) > Val(Mid(lastAddedSheet.CodeName, 6)) Then
Set lastAddedSheet = oneSheet
End If
Next oneSheet
End With
MsgBox lastAddedSheet.Name & " was last added."
End Sub
But it does not really work.
You can't reliably know what sheet was last added, because a sheet can be inserted before or after any existing sheet in a workbook, see Sheets.Add documentation.
Unless you're the one adding it. In which case, all you need to do is capture the Worksheet object returned by the Add method:
Dim newSheet As Worksheet
Set newSheet = wb.Worksheets.Add
Debug.Print newSheet.Name
Extracting the digits from the CodeName isn't going to be reliable either - especially if you assume that every sheet's code name begins with 5 letters. On a German machine, the CodeName of what we see as Sheet1 would be Tabelle1 - but then again the role of that digit is strictly to ensure uniqueness of the names of the VBComponent items in the VBA project, and none of it says it has anything to do with any sort of ordering.
As per #MathieuGuindon his answer, I can't think of any "simple" way to safely return the name of the latest added sheet. However if you willing to sacrifice some designated space in your project to store CodeNames you could try to utilize the Workbook_NewSheet event.
Private Sub Workbook_NewSheet(ByVal Sh As Object)
Dim lr As Long
With Sheets("Blad1")
lr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
.Cells(lr, 1) = ActiveSheet.CodeName
End With
End Sub
Obviously you need to optimize this to add names when adding sheets during runtime. In this simplified example I manually added the existing sheet "Blad1", and upon adding new sheets, the list grew.
When deleting you can utilize the SheetBeforeDelete event, like so:
Private Sub Workbook_SheetBeforeDelete(ByVal Sh As Object)
Dim ws As Object
Dim lr As Long, x As Long
Dim rng1 As Range, rng2 As Range, cl As Range
With Sheets("Blad1")
lr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
Set rng1 = .Range("A2:A" & lr)
For Each ws In ActiveWindow.SelectedSheets
For Each cl In rng1
If cl = ws.CodeName Then
If Not rng2 Is Nothing Then
Set rng2 = Union(rng2, cl)
Else
Set rng2 = cl
End If
End If
Next cl
Next ws
End With
If Not rng2 Is Nothing Then
rng2.Delete
End If
End Sub
Now to get the latest added sheet we can refer to the last cell in our designated range:
Sub LastAdded()
Dim lr As Long
With ThisWorkbook.Sheets("Blad1")
lr = .Cells(.Rows.Count, "A").End(xlUp).Row
Debug.Print "Last added sheet is codenamed: " & .Cells(lr, 1)
End With
End Sub
My take on it is that it would be safest to use the CodeName since they are least likely to get changed and are unique. We can also safely keep using our rng variable since there will always be at least one worksheet in your project (and that might just be the designated one if you protect it). Working in this project will now keep track of latest added worksheet.
Sheets could be a Chart or a Worksheet.
You could try use Worksheets instead of Sheets in your code.
sub test()
Dim lastAddedSheet As Worksheet
Dim oneSheet As Worksheet
With ThisWorkbook
Set lastAddedSheet = .WorkSheets(1)
For Each oneSheet In .WorkSheets
If Val(Mid(oneSheet.CodeName, 6)) > Val(Mid(lastAddedSheet.CodeName, 6)) Then
Set lastAddedSheet = oneSheet
End If
Next oneSheet
End With
MsgBox lastAddedSheet.Name & " was last added."
End Sub
I am trying to insert new row under a particular text(selected from userform) with the new text but getting an error "Object variable or With block variable not set" in the line "fvalue.Value = Me.txtremark.Value".
Please help me to find where exactly the mistake I did in the Code. I was trying to find many ways but failed.
Excel Table:
Required Output:
Private Sub cmdadd_Click()
Dim fvalue As Range
Dim wks As Worksheet
Set wks = ThisWorkbook.Worksheets("Sheet1")
wks.Activate
Set fvalue = wks.Range("B:B").Find(What:=Me.txtremark.Value, LookIn:=xlFormulas, LookAt:=xlWhole)
fvalue.Value = Me.txtremark.Value
fvalue.Offset(1).EntireRow.Insert Shift:=xlDown
fvalue.Offset(0, 1).Value = Me.txtplace.Value
End Sub
Try:
Option Explicit
Sub test()
Dim Position As Range, rngToSearch As Range
Dim strToFound As String
'Change strToFound value
strToFound = "Test"
With ThisWorkbook.Worksheets("Sheet1")
Set rngToSearch = .Range("B:B")
Set Position = rngToSearch.Find(strToFound, LookIn:=xlValues, Lookat:=xlWhole)
If Not Position Is Nothing Then
Debug.Print Position.Row
.Rows(Position.Row).Offset(1).EntireRow.Insert
End If
End With
End Sub
Try using a separate variable to pass values to the worksheet, or just refer to the textbox.
Additionally, activating (and selecting) is not necessary and will hurt your macro's speed and is prone to errors.
Option Explicit
Private Sub cmdadd_Click()
Dim fvalue As Range
Dim wks As Worksheet
Set wks = ThisWorkbook.Worksheets("Sheet1")
Set fvalue = wks.Range("B:B").Find(What:=Me.txtremark.Value, LookIn:=xlFormulas, LookAt:=xlWhole)
If Not fvalue Is Nothing Then
wks.Rows(fvalue.Row + 1).EntireRow.Insert
wks.Cells(fvalue.Row + 1, fvalue.Column + 1).Value = Me.txtremark.Value
End If
End Sub
I have taken the liberty to check if the value is found in the first place