Basically I'm creating a excel app that, when run, will prompt the user to point at the a specific excel file, and it will take the location in as a string, that works fine. What I am not sure how to do is choose a range in the active worksheet and take the value in each cell and combine them into 1 string.
This is my code so far:
Option Explicit
Sub locate_file()
Dim file As String
Dim sheet1_95 As String
Dim theRange As Range
'prompt user for location of other excel sheet'
file = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx")
'test input of location'
Workbooks("testing input file.xlsx").Sheets("location").Activate
Range("A1") = file
'activate the workbook and sheet'
Workbooks("95%.xlsx").Sheets("DT").Activate
'Testing retrieving cells as string'
Set theRange = Range("A2:A4")
'how do i retrieve values in this range and combine them into 1 string?'
End Sub
What I am not sure how to do is choose a range in the active worksheet
By using the Application.InputBox function (as opposed to VBA.InputBox):
dim r as range
set r = application.inputbox("Select a range", Type:=8)
and take the value in each cell and combine them into 1 string.
By looping through the cells:
dim c as range
dim s as string
for each c in r.cells
s = s & c.value
next
'Testing retrieving cells as string'
Set theRange = Range("A2:A4")
'how do i retrieve values in this range and combine them into 1 string?'
Dim c as int, x as int
Dim strValue as string
c = therange.rows.count
strValue = vbnullstring
for x = 1 to c
strValue = strValue & theRange.cells(x,1).value
next x
Related
I am new in VBA, so I am not familiar with all its capabilities. I have a worksheet with many "tables" in it. By tables, I do not mean actual Excel Table Object but chunks of data that are separated into "tables" via color/border formatting.
I can find which cell a specific table starts by finding the cell which contains "RefNum:". However, to avoid false detection of table, I would like to double check the next cells after it.
Essentially, what I want is not just to find "RefNum:" but to find the position of 3x1 array which contains the ff in correct order:
- RefNum:
- Database:
- ToolID:
Only then can I be sure that what I found was a real table.
I am thinking of finding "RefNum:" and doing if-else for verification, but maybe there is a more sophisticated way of doing it?
Thanks for the help.
Try this code:
Sub FindTables()
Dim cell As Range
Dim firstAddress As String
With Range(Cells(1, 1), Cells(Rows.Count, Columns.Count))
Set cell = .Find("RefNum", LookIn:=xlValues)
firstAddress = cell.Address
Do
'check cell next to "RefNum" and one after that
If LCase(cell.Offset(0, 1).Value) = "database" And LCase(cell.Offset(0, 2).Value) = "toolid" Then
'here, cell is first cell (ref num) of the table
cell.Interior.ColorIndex = 4
End If
Set cell = .FindNext(cell)
Loop While Not cell Is Nothing And cell.Address <> firstAddress
End With
End Sub
Based from Michal's code, this is the answer I came up with. It works well except for one thing. It does not detect the 1st cell address, only the 2nd and succeeding. Can anyone see where I made an error?
Option Explicit
Public Sub LogSum()
'Declare variables
Dim shtMacro As Worksheet 'Sheet where macro button is located
Dim Fname As Variant 'List of user-selected files
Dim bookLOG As Workbook 'Active logsheet file
Dim shtLOG As Worksheet 'Active worksheet from current active workbook
Dim WS_Count As Integer 'Number of worksheets in active workbook
Dim CellDB As Range 'First cell output for find "RefNum"
Dim FirstAddress As String 'Address of the first CellDB
Dim i As Integer, j As Integer 'Loop iterators
'Prompt user to get logsheet filenames
Fname = Application.GetOpenFilename("ALL files (*.*), *.*,Excel Workbook (*.xlsx), *.xlsxm,Excel 97-2003 (*.xls), *.xls", , "Open Logsheet Files", , True)
If (VarType(Fname) = vbBoolean) Then Exit Sub
DoEvents
'Iterate per workbook
For i = LBound(Fname) To UBound(Fname)
Set bookLOG = Workbooks.Open(Filename:=Fname(i), UpdateLinks:=0, _
ReadOnly:=True, IgnoreReadOnlyRecommended:=True) 'Open workbook i
WS_Count = bookLOG.Worksheets.Count 'Store max number of sheets
Debug.Print bookLOG.Name 'Print the workbook filename in log
'Iterate per worksheet in workbook i
For j = 1 To WS_Count
Debug.Print bookLOG.Worksheets(j).Name 'Print the current sheet in log
Set CellDB = bookLOG.Worksheets(j).UsedRange.Find("RefNum:", LookIn:=xlValues) 'Search for "RefNum:"
If (Not (CellDB Is Nothing)) Then
bookLOG.Worksheets(j).UsedRange.Select
Debug.Print "Something's found here."
FirstAddress = CellDB.Address 'Assign the 1st search address
Debug.Print FirstAddress
Do 'Check cell next to "RefNum:" and one after that
If CellDB.Offset(1, 0).Value = "DATABASE: " And CellDB.Offset(2, 0).Value = "Tester:" Then
Debug.Print "Yay! Got You"
Debug.Print CellDB.Address
Else
Debug.Print "Oops. False Alarm"
End If
Set CellDB = bookLOG.Worksheets(j).UsedRange.FindNext(CellDB)
Loop While CellDB.Address <> FirstAddress
Else
Debug.Print "Nothing found here."
End If
Next j
Next i
End Sub
I would like to generate new sheet for all values contains "_S" :
Example:
When user click on "Generate page", two new sheet are created (one sheet with title "Folder22_S" and other one with title "Folder3_S"
In second time, i would like that new sheet generated from a model (not generate a empty sheet)
My question is: How to do this ? I doesn't know how to find all values contains "_S" and get cell value ( Folder22_S and Folder3_S) ?
My pseudo VBA code:
Sub generate()
'Array contains all values *_S'
Dim AllValuesContains_S As Variant
AllValuesContains_S = Array("Folder22_S", "Folder3_S", ...)
For Each item As String In AllValuesContains_S
Sheets.Add.Name = item
Next
End Sub
I will assume the range you want to search is A2:C7. Adjust that portion of the code to be whatever range you need.
Sub New_Wksht()
Dim SearchRange as Range, c as Range
Dim sht as Worksheet
With ThiwWorkbook
Set SearchRange = .Sheets("Your Sheet Name").Range("A2:C7") 'Change sheet name and range to be what you need
For Each c in SearchRange
If Right(c.Value,2) = "_S" Then
Set sht = .Sheets.Add
sht.Name = c.Value
End If
Next C
End With
End Sub
I have 3 open Excel files which i have opened using this code;
Dim myWorkbooks As New Collection
Sub GetFile()
Dim fNameAndPath As Variant, i As Long, x As Variant
fNameAndPath = Application.GetOpenFilename("All Files (*.*), *.*", , "Select Files To Be Opened", , True)
If Not IsArray(fNameAndPath) Then
If fNameAndPath = False Then Exit Sub Else fNameAndPath = Array (fNameAndPath)
End If
For i = LBound(fNameAndPath) To UBound(fNameAndPath)
Set x = Workbooks.Open(fNameAndPath(i))
myWorkbooks.Add x
Next
End Sub
i merged all the Sheets i Need in one Workbook. There is a mastersheet called "KomKo" in this Workbook. And i have other Sheets which are "data (2)" , "data (3)" and "data(4)". These Sheets can be more then 4 so i might have Sheets called "data(11) " and so on. I would like to be able to copy Column C of all "data" Sheets and paste it to Column A of "KomKo" Sheet. i should be able to paste These values to the next empty value of that Column A.
How can i do this ?
So, after you have corrected your question, this code should do the desired work:
Dim masterSheet As Worksheet
Set masterSheet = Sheets("Komko")
'Variable to save the used Range of the master sheet
Dim usedRangeMaster As Integer
Dim ws As Worksheet
'loop through each worksheet in current workbook
For Each ws In Worksheets
'If sheetname contains "data" (UCase casts the Name to upper case letters)
If InStr(1, UCase(ws.Name), "DATA", vbTextCompare) > 0 Then
'calculate the used range of the master sheet
usedRangeMaster = masterSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
'Variable to save the used Range of the sub sheet
Dim usedRangeSub As Integer
'calculate the used range of the sub sheet
usedRangeSub = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row
'copy relevant range from the subsheet
ws.Range("C1:C" & usedRangeSub).Copy
'paste the copied range after the used range in column a
masterSheet.Range("A" & usedRangeMaster).PasteSpecial
End If
Next ws
Since you already have a collection containing the relevant workbooks, you can just loop through these and copy the relevant stuff into your main wb.
So define a variable for the master sheet(to be able to refer to it)
And one Variable inside the loop which holds the "subsheet":
Dim mastersheet As Workbook
Set mastersheet = ThisWorkbook 'Assuming the code is inside the master sheet
Dim wb As Workbook
For Each wb In myWorkbooks
'Copy stuff
'Example to get a value from the "subsheet"
mastersheet.Sheets("sheet1").Cells(1, 1).Value = wb.Sheets("sheet1").Cells(1, 1)
Next wb
Then inside the loop, copy column c for example and paste it into column a of the master sheet:
wb.Sheets("sheet1").Range("C1").EntireColumn.Copy
mastersheet.Sheets("sheet1").Range("A1").PasteSpecial
EDIT: Am I required to use the object model?
So I am having trouble with this program. I have written a GUI that has two list boxes and some buttons. I am trying to start the program, select a column of data/numbers to compare with another column of data/numbers on another worksheet and then copy the adjacent cells of the first to one specified in the program. The copy part of my code worked fine along but when I added all the sheet stuff in it quit working. I don't Know if it is because you can't compare on two sheets after you do a .Active/.Open or if I plain don't understand .Active and .Open. If I am doing something wrong, I don't have a clue how to fix it. Any Suggestions would be much appreciated.
Thanks
Nick
P.S I have included only the part of the code where I think there is a problem. If needed I can submit the whole thing.
Sub copy2()
Dim ColCopyTo As String 'the column you want to copy to
Dim ColSelect As String 'the column with the initial data
Dim ColCompare 'the column you want to compare the initial data with
Dim ColCopyFrom 'the column you want to copy data from
Dim RowCrntCompare As Long
Dim RowCrntSelect As Long
Dim RowLastColCompare As Long
Dim RowLastColSelect As Long
Dim SelectValue As String
Dim WorkSheetSelect As Worksheet 'the worksheet with initial data
Dim WorkSheetCompare As Worksheet ' the worksheet you want to compare initial data on
Dim WorkBookCompare As Workbook 'the workbook you want to compare initial data on
Dim WorkBookSelect As Workbook ' the workbook with initial data on it
Dim WorkSheetIndex As Integer
With Sheet1
continue = False 'initialise continue to false
MsgBox "Select the Workbook and Worksheet"
CommandButton2.Visible = True
CommandButton1.Visible = False
Call Wait 'pause until button is clicked
'MsgBox ListBox2.value
WorkSheetIndex = udfSheetIndex(ListBox2.value) 'index of the worksheet
'MsgBox WorkSheetIndex
'Set WorkBookSelect = Workbooks(ListBox1.value)
Set WorkBookSelect = Workbooks.Open(ListBox1.value)
WorkBookSelect.Activate
Set WorkSheetSelect = ActiveWorkbook.Sheets(WorkSheetIndex)
'Set WorkBookCompare = ActiveWorkbook.Sheets(WorkSheetSelect)
'WorkBookSelect.Activate ' set the initial workbook to active
WorkSheetSelect.Activate ' set the initial worksheet to active
ColSelect = InputBox("which column do you want to select From") 'column you want to first select for copying
ColCopyFrom = InputBox("which column do you want to copy data ColCopyFrom") 'where you are copying data from
continue = False 'reset continue to false
MsgBox "select the workbook and worksheet you want to compare to"
CommandButton2.Visible = True
Call Wait 'wait for button click
'Set WorkBookCompare = Workbooks(ListBox1.value)
Set WorkBookCompare = Workbooks.Open(ListBox1.value)
WorkBookCompare.Activate
MsgBox ListBox2.value
WorkSheetIndex = udfSheetIndex(ListBox2.value) 'index of the worksheet
MsgBox "listbox2" & ListBox2.value
MsgBox WorkSheetIndex
Set WorkSheetCompare = ActiveWorkbook.Sheets(WorkSheetIndex)
WorkBookCompare.Activate 'set the second workbook to active
WorkSheetCompare.Activate ' set the second worksheet to active
ColCompare = InputBox("which column do you want to compare to ") 'the column you are comparing it to
ColCopyTo = InputBox("which column do you want to copy data to") 'where you are copying data to
RowLastColSelect = .Range(ColSelect & .Rows.Count).End(xlUp).Row 'length of the selected column
RowLastColCompare = .Range(ColCompare & .Rows.Count).End(xlUp).Row 'length of ColCompare
For RowCrntSelect = 1 To RowLastColSelect Step 1 ' from 1 to last
SelectValue = .Cells(RowCrntSelect, ColSelect).value ' value of cell
'MsgBox SelectValue
If SelectValue <> "" Then
For RowCrntCompare = 1 To RowLastColCompare Step 1
If SelectValue = Cells(RowCrntCompare, ColCompare).value Then
.Cells(RowCrntCompare, ColCopyTo).value = _
.Cells(RowCrntSelect, ColCopyFrom).value
End If
Next RowCrntCompare
End If
Next RowCrntSelect
End With
End Sub
On your line:
WorkSheetIndex = udfSheetIndex(ListBox2.value) 'index of the worksheet
try using:
WorkSheetIndex = Sheets(ListBox2.value).Index
UDF stands for "User Defined Function", so I'm guessing its not working because the function is not set up correctly.
VBA - As the typical question starts, I am NEW (brand new) to VBA. I want to open a spreadsheet that will allow me to open multilple files (undetermined number) from one folder. It will then select certain cells from each file, copy and paste them into my original spreadsheet. Of course, then close all of the other files.
See if this will help. Because we're copying from an irregular (non-contiguous) range, it's a bit difficult to copy to another irregular range. So for that reason, the target range is "A1,B1,C1,D1,E1, etc", instead of "A1,B1,C1,E1,H1, etc". If that doesn't work for you, we'll need to try something a bit more elaborate.
Sub copyMultFiles()
Dim rS As Range, rT As Range, Cel As Range
Dim wBs As Workbook 'source workbook
Dim wS As Worksheet 'source sheet
Dim wT As Worksheet 'target sheet
Dim x As Long 'counter
Dim c As Long
Dim arrFiles() As String 'list of source files
Dim myFile As String 'source file
' change these to suit requirements
Const csMyPath As String = "C:\Documents and Settings\Dave\Desktop\TestFolder\" 'source folder
Const csMyFile As String = "*.xls" 'source search pattern
Const csSRng As String = "$C$1,$C$10,$C$11,$C$34,$D$1" 'source range
Const csTRng As String = "$A$1" 'target range
Application.ScreenUpdating = False
' target sheet
Set wT = ThisWorkbook.Worksheets(1) 'change to suit
' clear sheet
wT.Cells.Clear 'may not want this, comment out!!!
' aquire list of files
ReDim arrFiles(1 To 1)
myFile = Dir$(csMyPath & csMyFile, vbNormal)
Do While Len(myFile) > 0
arrFiles(UBound(arrFiles)) = myFile
ReDim Preserve arrFiles(1 To UBound(arrFiles) + 1)
myFile = Dir$
Loop
ReDim Preserve arrFiles(1 To UBound(arrFiles) - 1)
Set rT = wT.Range(csTRng)
' loop thru list of files
For x = 1 To UBound(arrFiles)
Set wBs = Workbooks.Open(csMyPath & arrFiles(x), False, True) 'open wbook
Set wS = wBs.Worksheets(1) 'change sheet to suit
c = 0
Set rS = wS.Range(csSRng)
'copy source range to current target row
For Each Cel In rS
Cel.Copy rT.Offset(, c) 'next column
c = c + 1
Next Cel
wBs.Close False
Set rT = rT.Offset(1) 'next row
DoEvents
Next x 'next book
Erase arrFiles
Application.ScreenUpdating = True
End Sub