I am trying to copy named range in excel from one sheet to another, this works superb when I am using a static name. However now I would like to get the named range from a userform list box, and I am unsure how to do this. My copy function takes in the row number and I need to find this row number based on the string coming from the Listbox. If the listbox says Bolts the named range would be _OutputBolts which is refered to A123.
Call copyRows(ws, ThisWorkbook.Sheets("Templates").[_DrawingInputs].Row)
Call copyRows(ws, ThisWorkbook.Sheets("Templates").[_GeneralInputs].Row)
Call copyRows(ws, ThisWorkbook.Sheets("Templates").[_MaterialData].Row)
If GUI.ListBox_AdditionalComponents.ListCount > 0 Then
For i = 0 To GUI.ListBox_AdditionalComponents.ListCount - 1
namedRange = "[_Output" & GUI.ListBox_AdditionalComponents.List(i) & "]"
Call copyRows(ws, ThisWorkbook.Sheets("Templates").namedRange.Row)
Next i
End If
The copy procedure
Public Sub copyRows(ByRef shNew As Worksheet, startRow As Integer)
Dim i, j As Integer
Dim wsTemplates As Worksheet
Dim temp As Variant
Dim rowOverview As Integer
Dim lastCol As Integer
On Error Resume Next
Set wsTemplates = ThisWorkbook.Sheets("Templates")
i = startRow ' Where to copy from in templates
j = getLastRow(shNew, 1) 'Where to copy to, i.e append
If j > 2 Then
j = j + 2
End If
Do While wsTemplates.Cells(i, 1) <> ""
'copy the old range
wsTemplates.Rows(i).EntireRow.Copy
'paste it
shNew.Rows(j).EntireRow.Select
shNew.Paste
'format height
temp = wsTemplates.Rows(i).Height
shNew.Rows(j).RowHeight = CInt(temp)
' fill in the value from the GUI
temp = ""
temp = GUI.Controls("TextBox_" & Replace(shNew.Cells(j, 1).value, " ", "")).value
If temp = "" Then
temp = GUI.Controls("ComboBox_" & Replace(shNew.Cells(j, 1).value, " ", "")).value
End If
If temp <> "" Then
shNew.Cells(j, 4).value = temp
End If
'hyperlink drawing
If shNew.Cells(j, 1).value = "Drawing Name" Then
Call createHyperLink(shNew, j, 4, shNew.Cells(j, 4).value, GetFileNameWithOutExtension(getFilenameFromPath(shNew.Cells(j, 4).value)), shNew.Cells(j, 4).value)
End If
'update counters
i = i + 1
j = j + 1
Loop
' Format column widths, seems to be bug in this one...Maybe move out due to the fact we could do this once..
lastCol = getLastColumn(wsTemplates, 1)
For i = 1 To lastCol
temp = wsTemplates.Cells(1, i).Width
shNew.Columns(i).ColumnWidth = temp
Next i
End Sub
Solved by using Range(address), see comment
Related
I'm working on a VBA word script that reads in some names and relevant info from an excel sheet, performs some computations to organize them correctly, and then pastes them into the word doc. This went well until I decided to make a function that would move a cell with the value "Anonymous" to the top of a range. For some reason, this isn't happening, and it appears to be because the .Cells method isn't always referring to the cell it was called on.
As the script itself is fairly long, I won't post the entire thing here. However, the relevant parts are a For loop in the main sub which deals with cells with the value "Anonymous"
For curCol = 7 To 15
lastRow = appXL.Cells(appXL.Rows.Count, curCol).End(xlUp).Row
For curRow = 1 To lastRow
Dim curCell As excel.Range
Set curCell = appXL.Cells(curRow, curCol)
Dim anonCount As Integer
anonCount = 0
If curCell.Value = "Anonymous" Or curCell.Value = "Anonymous*" Then
If anonCount < 1 Then
anonCount = anonCount + 1
MoveAnon (curRow), (curCol), (lastRow)
Else
anonCount = anonCount + 1
curCell.Value = curCell.Value + " (" + CStr(anonCount) + ")"
MoveAnon (curRow), (curCol), (lastRow)
End If
End If
Next curRow
Next curCol
You'll notice that within this loop is a call to a subroutine "MoveAnon" which is
Sub MoveAnon(currentRow As Integer, currentCol As Integer, thelastRow As Integer)
Dim text As String
Debug.Print ("Using Row: " + CStr(currentRow) + ", Column: " + CStr(currentCol) + ", Last Row: " + CStr(thelastRow))
text = excel.Application.ActiveSheet.Cells(currentRow, currentCol)
Debug.Print ("Hit On: " & excel.Application.ActiveSheet.Cells(currentRow, currentCol))
If currentRow > 1 Then
excel.Application.ActiveSheet.Range(excel.Application.ActiveSheet.Cells(1, currentCol).Address, excel.Application.ActiveSheet.Cells(currentRow - 1, currentCol).Address).Cut excel.Application.ActiveSheet.Range(excel.Application.ActiveSheet.Cells(2, currentCol).Address)
excel.Application.ActiveSheet.Cells(1, currentCol).Value = text
End If
End Sub
Through testing and with Deubg.Print, I've noticed that the line Debug.Print ("Hit On: " & excel.Application.ActiveSheet.Cells(currentRow, currentCol)) refers to all manner of different cells then the one on which it was called. For example, whenever I use Cells(6, 15), I get a value from a cell that is actually on row 42, column 15. The difference between the cell its called on and the cell it returns is not always the same (I've seen -7, +36, and 0), but it is always in the correct column.
Does anyone have any idea as to what my cause this behavior to arise? Thanks for any help.
It's much faster to read the whole range into an array, then populate another array of the same size with the "Anonymous*" at the top, and replace the range values using the second array.
Eg.
Sub Tester()
Dim curCol As Long, ws As Worksheet
Set ws = ActiveSheet
For curCol = 7 To 15
MoveAnon ws.Range(ws.Cells(1, curCol), _
ws.Cells(ws.Rows.Count, curCol).End(xlUp))
Next curCol
End Sub
'Given a (single-column) range, move all values like "Anonymous*"
' to the top of the range
Sub MoveAnon(rng As Range)
Const TXT As String = "Anonymous*"
Dim v, i As Long, num As Long
Dim arrIn, arrOut, nA As Long, nX As Long
num = Application.CountIf(rng, TXT) 'how many to float up
If num = 0 Then Exit Sub 'nothing to do here?
arrIn = rng.Value 'read to array
ReDim arrOut(1 To UBound(arrIn, 1), 1 To UBound(arrIn, 2)) 'size output array
For i = 1 To UBound(arrIn, 1) 'loop the input array
v = arrIn(i, 1)
If v Like TXT Then
nA = nA + 1
arrOut(nA, 1) = v '"Anonymous*" goes at the top
Else
nX = nX + 1
arrOut(num + nX, 1) = v 'everything else goes below
End If
Next i
rng.Value = arrOut 'replace using the shuffled array
End Sub
i have some label data to print in columns and rows format based on the user defined input Value. their are 3 main inputs based conditions:
1) No of starting label to skip 2) No of label per Row 3) No of Rows Per page
I have one data sheet which has data in column A and No of copies to be printed in column B. i am attaching examples images with different input and output in page i expect to be printed. Also giving link to code which could be relevant for my purpose.
Data Sheet
Print Sheet
My codes are limited to 3 columns with unlimited rows and without skip
Here Can you tweak these codes for Userform : Make it small and efficient are codes for dynamic userfrom textbox creation given by #Brian M Stafford but not sure how to implement for this purpose
Public Sub GenerateLabels()
Dim CopyRowValue As String
Dim SecondDataCol, ThirdDataCol, FirstDataCol As Long
Dim SecondDataRow, ThirdDataRow, FirstDataRow As Long
Set shdata = ThisWorkbook.Sheets("Database")
Set shgenerate = ThisWorkbook.Sheets("LabelGenerate")
Set shDesignFormat = ThisWorkbook.Sheets("LabelDesignFormatBeforePrint")
FirstDataCol = shgenerate.Cells(1, shgenerate.Columns.Count).End(xlToLeft).Column
SecondDataCol = shgenerate.Cells(1, shgenerate.Columns.Count).End(xlToLeft).Column
ThirdDataCol = shgenerate.Cells(1, shgenerate.Columns.Count).End(xlToLeft).Column
FirstDataRow = shgenerate.Cells(shgenerate.Rows.Count, "A").End(xlUp).Row
SecondDataRow = shgenerate.Cells(shgenerate.Rows.Count, "C").End(xlUp).Row
ThirdDataRow = shgenerate.Cells(shgenerate.Rows.Count, "E").End(xlUp).Row
'======== Copy From Data Sheet============
Last_Row = Sheets("Database").Range("A" & Rows.Count).End(xlUp).Row
For r = 2 To Last_Row
shdata.Cells(x, "A").Copy
shDesignFormat.Range("B3").Paste 'pasting data to design sheet before print (to format data)
CopyRowValue = Worksheets("Database").Cells(r, "B").value
For r2 = 1 To CopyRowValue
'=====Paste to Generate Sheet ====
'Cells(FirstDataRow + 1, FirstDataCol + 1).Offset(0, 0).Select
If IsEmpty(shgenerate.Cells(FirstDataRow + 0, FirstDataCol + 0).Offset(0, 0).value) = True Then
shDesignFormat.Range("B3").Copy _
Destination:=shgenerate.Cells(FirstDataRow + 0, FirstDataCol + 0).Offset(0, 0)
ElseIf IsEmpty(shgenerate.Cells(SecondDataRow + 0, SecondDataCol + 2).Offset(0, 0).value) = True Then 'offset used to find empty cell if design layout changed
shDesignFormat.Range("B3").Copy _
Destination:=shgenerate.Cells(SecondDataRow + 0, SecondDataCol + 2).Offset(0, 0)
ElseIf IsEmpty(shgenerate.Cells(ThirdDataRow + 0, ThirdDataCol + 4).Offset(0, 0).value) = True Then
shDesignFormat.Range("B3").Copy _
Destination:=shgenerate.Cells(ThirdDataRow + 0, ThirdDataCol + 4).Offset(0, 0)
SecondDataRow = SecondDataRow + 2
ThirdDataRow = ThirdDataRow + 2
FirstDataRow = FirstDataRow + 2
End If
Next r2
Next r
Application.CutCopyMode = False
End Sub
Looking at your code, my first thought was it could be simplified. Once I did this, I began modifying to add needed requirements. The main task was keeping track of the current location. The code ended up like this:
Option Explicit
Public Sub GenerateLabels(ByVal LabelsToSkip As Integer, ByVal LabelsPerRow As Integer, ByVal RowsPerPage As Integer)
Dim shdata As Worksheet
Dim shgenerate As Worksheet
Dim shDesignFormat As Worksheet
Dim curRow As Long
Dim curCol As Long
Dim RowsPerPageCount As Long
Dim r As Long
Dim r2 As Long
Set shdata = ThisWorkbook.Sheets("Database")
Set shgenerate = ThisWorkbook.Sheets("LabelGenerate")
Set shDesignFormat = ThisWorkbook.Sheets("LabelDesignFormatBeforePrint")
shgenerate.UsedRange.ClearContents
curRow = 1
curCol = 1
RowsPerPageCount = 1
For r = 2 To shdata.Range("A" & Rows.Count).End(xlUp).Row
'======== Copy From Data Sheet============
shdata.Cells(r, "A").Copy
shDesignFormat.Range("B3").PasteSpecial 'pasting data to design sheet before print (to format data)
For r2 = 1 To shdata.Cells(r, "B").Value + LabelsToSkip
'=====Paste to Generate Sheet ====
If curCol > LabelsPerRow * 2 Then '* 2 for double spacing
curCol = 1
If RowsPerPage > 0 And (RowsPerPageCount + 1) Mod (RowsPerPage + 1) = 0 Then
curRow = curRow + 10 'new page
RowsPerPageCount = 1
Else
curRow = curRow + 2
RowsPerPageCount = RowsPerPageCount + 1
End If
End If
If r2 > LabelsToSkip Then
LabelsToSkip = 0
shDesignFormat.Range("B3").Copy Destination:=shgenerate.Cells(curRow, curCol)
End If
curCol = curCol + 2
Next r2
Next r
Application.CutCopyMode = False
End Sub
I recommend using Option Explicit and declaring all variables that you need.
I have an invoice from a service provider that I need to format so I can use the data in Excel. But, the formatting is not consistent.
There are three (3) columns:
ID
Description
Amount
Many ID#s on the invoice have a one line (row) description.
But just as many have 2-11 lines (rows) of description.
The ID# is only listed once with each set of description lines.
Up to this point, I have used Excel Formulas. But, all my formulas is making things go very slow.
VBA would be way faster.
What I have done is created an index system looking for new ID#s.
Then I have created a cascading concatenate formula based on the given index system.
The amount has been easy to pull out using a LEFT formula, since the amount lists USD.
I then have a second sheet that does a VLOOKUP off of the first sheet to pull the ID's, final concatenated descriptions, and Amounts.
Our last invoice had 17,427 lines of data with only 1,717 ID#s.
Here is an example of what I am working with:
I want it to look like this:
one of the possible solutions below:
'assume that Id in column `A`, Description in column `B`, Amount in `C` and header in row 1
Sub somecode()
Dim wb As Workbook: Set wb = ActiveWorkbook
Dim sh As Worksheet: Set sh = wb.ActiveSheet
Dim lastRow&: lastRow = sh.Cells(Rows.Count, "B").End(xlUp).Row
Dim idColumn As Range: Set idColumn = sh.Range("A1:A" & lastRow)
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
Dim cl As Range, keyID, valueDescription$, valueAmount$
For Each cl In idColumn
If cl.Value <> "" And Not dic.exists(cl.Value) Then
dic.Add cl.Value, sh.Cells(cl.Row, "B").Value & "|" & sh.Cells(cl.Row, "C").Value
keyID = cl.Value
valueDescription = sh.Cells(cl.Row, "B").Value
valueAmount = sh.Cells(cl.Row, "C").Value
ElseIf cl.Value = "" Then
valueDescription = valueDescription & " " & sh.Cells(cl.Row, "B").Value
dic(keyID) = valueDescription & "|" & valueAmount
End If
Next cl
Set sh = wb.Sheets.Add: sh.Name = "Result " & Date & " " & Replace(Time(), ":", "-")
Dim dkey, xRow&: xRow = 1
For Each dkey In dic
sh.Cells(xRow, "A").Value = dkey
sh.Cells(xRow, "B").Value = Split(dic(dkey), "|")(0)
sh.Cells(xRow, "C").Value = Split(dic(dkey), "|")(1)
xRow = xRow + 1
Next dkey
sh.Columns("A:C").AutoFit
End Sub
test:
I wrote code for you to do this job. Please install it in a standard code module. That is one that you have to insert. None of the existing is suitable.
Option Explicit
Enum Nws ' Worksheet setup (set values as required)
NwsFirstDataRow = 2
NwsNumColumns = 8 ' total number of columns in the sheet
NwsID = 1 ' Columns: 1 = column A
NwsDesc ' undefined = previous + 1
NwsAmt = 5 ' 5 = column E
End Enum
Sub MergeRows()
' Variatus #STO 24 Jan 2020
Dim Wb As Workbook
Dim Ws As Worksheet
Dim Rng As Range
Dim RowArr As Variant
Dim Desc As String, Amt As Double
Dim Tmp As Variant
Dim R As Long
' define workbook and worksheet as required
Set Wb = ActiveWorkbook ' this need not be ThisWorkbook
Set Ws = Wb.Worksheets("Invoice") ' change as appropriate
Application.ScreenUpdating = False
With Ws
R = .Cells(.Rows.Count, NwsDesc).End(xlUp).Row
For R = R To NwsFirstDataRow Step -1
If (R Mod 25) = 3 Then 'NwsFirstDataRow Then
Application.StatusBar = "Another " & R & " rows to process."
End If
Tmp = Trim(.Cells(R, NwsID).Value)
If Len(Tmp) Then
Set Rng = Range(.Cells(R, 1), .Cells(R, NwsNumColumns))
RowArr = Rng.Value
RowArr(1, NwsAmt) = TextToAmount(RowArr(1, NwsAmt))
If Len(Desc) Then
' if you want a comma instead of a line break
' replace Chr(10) with "," in the next line:-
RowArr(1, NwsDesc) = RowArr(1, NwsDesc) & Chr(10) & Desc
RowArr(1, NwsAmt) = RowArr(1, NwsAmt) + Amt
Desc = ""
Amt = 0
End If
With Rng
.Value = RowArr
.Cells.VerticalAlignment = xlTop
.Cells(NwsAmt).NumberFormat = "$#,##0.00"
End With
.Rows(R).AutoFit
Else
Tmp = Trim(.Cells(R, NwsDesc).Value)
If Len(Desc) Then Desc = Chr(10) & Desc
Desc = Tmp & Desc
Tmp = TextToAmount(.Cells(R, NwsAmt).Value)
If Tmp Then Amt = Amt + Tmp
.Rows(R).EntireRow.Delete
End If
Next R
End With
With Application
.ScreenUpdating = True
.StatusBar = "Done"
End With
End Sub
Private Function TextToAmount(ByVal Amt As Variant) As Double
Dim Tmp As Variant
Tmp = Trim(Amt)
If Len(Tmp) Then Tmp = Mid(Tmp, InStr(Tmp, "$") + 1)
TextToAmount = Val(Tmp)
End Function
Before you can run it you need to set the enumerations at the top to tell the code where your data and columns are. Toward the same end, please set the variables for workbook (Wb) and worksheet (Ws) in the procedure itself.
Note that the code adds the price, if any, in the rows that are deleted to the amount set against the remaining item.
Finally, you will see that I programmed the different rows to become lines in a single cell. That isn't what you asked for. If you want the items separate by commas look for the remark in the code where you can change this.
I am trying to copy a specific cell and 3 columns from multiple files into a single column on another spreadsheet.
The part called "import" simply allows to select multiple files. The part "Datacopy" should copy the desired values.
Sub import()
Dim oFileDialog As FileDialog
Set oFileDialog = Application.FileDialog(msoFileDialogFilePicker)
oFileDialog.AllowMultiSelect = True
oFileDialog.InitialFileName = "C:\Users\L18938\Desktop\New_folder" ' can set your default directory here
oFileDialog.Show
Dim iCount As Integer
For iCount = 1 To oFileDialog.SelectedItems.Count
Call Datacopy(oFileDialog.SelectedItems(iCount))
Next
End Sub
Public Function Datacopy(strPath As String)
Dim filePath As String
Dim FileNum As Integer
filePath = strPath
Dim startDate As String
If Range("A2").Value <> "" Then
Range("A1").End(xlDown).Offset(1, 0).Select
Else:
Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Offset(1, 0).Select
End If
currentRow = 0
rowNumber = 0
Open filePath For Input As #1
'EOF(1) checks for the end of a file
Do Until EOF(1)
If rowNumber = 0 Then
startDate = lineitems(2)
End If
If rowNumber > 18 And item <> "" Then
ActiveCell.Offset(currentRow, 0) = startDate
ActiveCell.Offset(currentRow, 1) = lineitems(0)
ActiveCell.Offset(currentRow, 2) = lineitems(1)
ActiveCell.Offset(currentRow, 3) = lineitems(2)
currentRow = currentRow + 1
End If
End If
Next item
rowNumber = rowNumber + 1
Loop
Close #1
End Function
When I run it I get the error "sub or function not defined".
The cells I am targeting are:
C1 -> is a date, different in each file, to be copied in column A
Columns A18:A, B18:B, C18:C -> are data to be copied in columns B, C, D respectively.
It is important to copy multiple files, as I have more than 180.
Your problem is "startDate = lineitems(2)". There's nothing in your code that assigns any kind of value to "lineitems".
Hopefully the title is clear. I am trying to search through multiple tables on a single sheet. The information I am looking for is the same for all of the tables, just that the corresponding column is located in different spots (e.g. in one table the column I want to search is in I, while for another table it could be in O.) which makes it a bit more challenging for me.
I want to search through each column that has the same title (Load Number) and depending on its value, copy that entire row over to a sheet that corresponds with that value.
Below is what I have so far in VBA as well as a picture to hopefully clarify my issue.
Any help/advice is appreciated!
http://imgur.com/a/e9DyH
Sub Load_Number_Finder()
Dim ws As Worksheet
Dim i As Integer
Dim j As Integer
j = 1
Set ws = Sheets.Add(After:=Sheets("Master"))
ws.Name = ("Test Load " & j)
i = 1
Sheets("Master").Select
For Each cell In Sheets("Master").Range("M:M")
If cell.Value = "1" Then
j = 1
'Set WS = Sheets.Add(After:=Sheets("Master"))
'WS.Name = ("Test Load " & j)
matchRow = cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets("Test Load " & j).Select
ActiveSheet.Rows(i).Select
ActiveSheet.Paste
Sheets("Master").Select
i = i + 1
ElseIf cell.Value = "" Then
' 2, 3, 4, 5, cases
Else
' Something needs to go here to catch when it doesnt have a load number on it yet
End If
' Err_Execute:
' MsgBox "An error occurred."
Next
End Sub
Try this function. This should work for you. Let me know what the results are with your sheet. I made a mock up sheet and tested it, it worked. I can make changes if this is not exactly what you are looking for.
Option Explicit
Sub copyPaste()
Dim rowCount, row_ix, temp, i As Integer
Dim TD_COL_IX As Integer
Dim td_value As String
Dim td_values() As String
rowCount = Worksheets("Master").Cells(Rows.Count, "A").End(xlUp).Row
For row_ix = 1 To rowCount
temp = isNewTable(CInt(row_ix))
If temp > 0 Then
TD_COL_IX = temp
ElseIf TD_COL_IX > 0 Then
td_value = Worksheets("Master").Cells(row_ix, TD_COL_IX)
If Not td_value = "" Then
td_values = Split(td_value, " ")
For i = 0 To UBound(td_values)
If Not sheetExists("Test Load " & td_values(i)) Then
Sheets.Add.Name = "Test Load " & td_values(i)
End If
If Worksheets("Test Load " & td_values(i)).Cells(1, 1).Value = "" Then
Worksheets("Master").Range(Worksheets("Master").Cells(row_ix, 1), Worksheets("Master").Cells(row_ix, TD_COL_IX - 1)).Copy _
Destination:=Worksheets("Test Load " & td_values(i)).Cells(1, 1)
Else
Dim rowCount_pasteSheet As Integer
rowCount_pasteSheet = Worksheets("Test Load " & td_values(i)).Cells(Rows.Count, "A").End(xlUp).Row
Worksheets("Master").Range(Worksheets("Master").Cells(row_ix, 1), Worksheets("Master").Cells(row_ix, TD_COL_IX - 1)).Copy _
Destination:=Worksheets("Test Load " & td_values(i)).Cells(rowCount_pasteSheet + 1, 1)
End If
Next i
End If
End If
Next row_ix
End Sub
Function isNewTable(row_ix As Integer) As Integer
Dim colCount, col_ix As Integer
colCount = Worksheets("Master").Cells(row_ix, Columns.Count).End(xlToLeft).Column
For col_ix = 1 To colCount
If Not IsError(Worksheets("Master").Cells(row_ix, col_ix).Value) Then
If Worksheets("Master").Cells(row_ix, col_ix).Value = "LD #" Then
isNewTable = col_ix
Exit Function
End If
End If
Next col_ix
isNewTable = 0
End Function
' ####################################################
' sheetExists(sheetToFind As String) As Boolean
'
' Returns true if the sheet exists, False otherwise
' ####################################################
Public Function sheetExists(sheetToFind As String) As Boolean
Dim sheet As Worksheet
sheetExists = False
For Each sheet In Worksheets
If sheetToFind = sheet.Name Then
sheetExists = True
Exit Function
End If
Next sheet
End Function