I have an Excel spreadsheet with many tabs. I'd like to export the last column of each sheet in a text file (all in the same file, the first line of the second sheet must go just after the last line of the fist sheet).
The thing is the number of columns changes from one sheet to another. The number of the last column can be given by the last non empty cell on the first row.
I've seen how to write in a file, but I'm clueless on how to iterate over sheets and rows...
Any help is welcome. Thanks.
You can find the last cell in a row using this code:
Sub LastCellInRow()
Range("IV1").End(xlToLeft).Select
End Sub
You can iterate through every Worsheet using the Worksheets collection:
Sub LoopThroughSheets()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
'** Perform code here **
Next ws
End Sub
This works:
Dim r As Range
Dim s As Worksheet
Dim wbSource As Workbook
Dim wbDestination As Workbook
Dim lastcol As Long
Dim lastrow As Long
Dim cumrow As Long
Dim i As Long
Set wbSource = ActiveWorkbook
Set wbDestination = Workbooks.Open("C:\destination.xls")
cumrow = 0
For Each s In wbSource.Worksheets
lastcol = s.Cells(1, s.Columns.Count).End(xlToLeft).Column
lastrow = s.Cells(s.Rows.Count, lastcol).End(xlUp).Row
Set r = s.Cells(1, lastcol).Resize(lastrow, 1) ' This is your column
' Copy it to appropriate location on destination sheet
wbDestination.Sheets(1).Cells(cumrow + 1, 1).Resize(lastrow, 1) = r
cumrow = cumrow + lastrow
Next s
The above was written and tested while on a video conference call!
Related
I am trying to consolidate data from a list of file paths into one worksheet then add the names per dataset. I have a list of names and paths set up like this in Excel:
Name1, Path1
Name2, Path2
Name3, Path3
The macro I have written so far loops through the paths, copy and paste into the master spreadsheet starting in the first empty in column B. What I want the macro to also do is also fill in column A with Name1, Name2, and Name3 next to the respective dataset. I got the macro do to the first part but now I can't get it to do the naming part. Here is my code so far:
Sub Data()
Dim ws As Worksheet, dataws As Worksheet
Dim wkb As Workbook, wkbFrom As Workbook
Dim wkblist As Range
Dim fromtab As String
Dim Name As String
For Each wkblist In Sheets("Ref").Range("d4:d18")
If wkblist.Value = "" Then
Exit For
Else
Set wkb = ThisWorkbook
Set wkbFrom = Workbooks.Open(wkblist)
Set ws = wkb.Sheets("Ref")
Set dataws = wkb.Sheets("Data")
fromtab = ws.Range("b22")
wkbFrom.Worksheets(fromtab).Range("b2:z200").Copy
dataws.Cells(Rows.Count, 5).End(xlUp).Offset(1).PasteSpecial xlValues
Application.CutCopyMode = False
wkbFrom.Close
End If
Next wkblist
End Sub
Ta,
I'm not too sure what worksheet you want the names to be pasted; I assume the data WS in the code below. Also, I would set the wkb, ws, and dataws outside of the loop since they are or belong to "ThisWorkbook". Not that it hurts to be inside of the loop, but you're just resetting them each time the loop runs.
The code below should find the range of rows that you just pasted into dataws. Then, it copies the names that are related to the wkblist in Col C into Col A of dataws.
Dim colARow, colBRow As Long
' Place code below after you paste the paths into Col B of the worksheet
' Find first blank in Col A
colARow = dataws.Cells(Rows.Count, 1).End(xlUp).Row + 1
' Find last filled cell in Col B
colBRow = dataws.Cells(Rows.Count, 2).End(xlUp).Row
dataws.Range("A" & colARow & ":A" & colBRow).Value = wkblist.Offset(0,-1).Value
I have a large sheet of data:
Updated Data
where i need to copy only a speacific part of this data to another worksheet:
The data i need to copy is always 4 cells wide however can be at any row and column. The first column cell at the top will allways be the same text value and i need to copy then from that found cell, 4 cells across to the right and then down to the cells are empty. All subsequent ranges after the first will use the same columns have several empty cells bother above and below each range needed. The macro will be run using a "button" so doesn't need to be checking the value of the cell all the time. The images are simplified versions of the data but are very accurate. 0 is used to show data surrounding range, HELLO is the data inside the range and INT_EXT_DOOR is my searched for cell value which can be in any column between data sets but will be the same inside each data set. The first range always starts at row 2.
Each range has to be numbered, defined by another worksheets cell value. For example, if my cell value is 1 i need it to copy range 1, if my value is 2 copy range 2 ect.
I have been trying to no luck to get anything that works like needed and would appreciate any help, thanks.
Test the next function, please:
Private Function testReturnBlock(strBlock As String, blkNo As Long)
Dim sh As Worksheet, ws As Worksheet, lastRow As Long, searchC As Range
Dim rng As Range
Set sh = ActiveSheet ' use here your sheet to be processed
Set ws = Worksheets("Return") 'use here your sheet where the data will be returned
Set searchC = sh.UsedRange.Find(strBlock)
If searchC Is Nothing Then MsgBox "No such a field in the worksheet...": Exit Function
lastRow = sh.Cells(Rows.Count, searchC.Column).End(xlUp).row
'The following part works well only if the blocks are separated by empty rows, as you said it is your sheet data case...
Set rng = sh.Range(searchC, sh.Cells(LastRow, searchC.Column)).SpecialCells(xlCellTypeConstants)
ws.Range("A1").Resize(rng.Areas(blkNo).Rows.Count, 4).Value = rng.Areas(blkNo).Resize(, 4).Value
End Function
The above function should be called like this:
Sub testRetBlock()
testReturnBlock "INT_EXT_DOOR", 2
End Sub
But in order to see that the correct range has been returned, you must adapt them in a way (in your test sheet), do differentiate. I mean the second one to contain "HELLO1" (at least on its first row), the following "HELLO2" and so on...
Try this routine if it does what you need. otherwise it should be a good start for adding whatever you need on top.
Option Explicit
Sub CopyBlock()
Dim wb As Excel.Workbook
Dim wsSource As Excel.Worksheet
Dim wsDest As Excel.Worksheet
Dim wsSelect As Excel.Worksheet
Dim lBlockNo As Long
Dim strCellID As String
Dim lBlock As Long
Dim lRow As Long
Dim lBlockRow As Long
Dim lBlockCol As Long
Dim searchRange As Excel.Range
Dim bRange As Excel.Range
Dim cRange As Excel.Range
Set wb = ActiveWorkbook
' set the worksheet objects
Set wsSource = wb.Sheets("Source")
Set wsDest = wb.Sheets("Dest")
Set wsSelect = wb.Sheets("Select") ' here you select which block you want to copy
' Identifier String
strCellID = "INT_EXT_DOOR"
' Which block to show. We assume that the number is in cell A1, but could be anywhere else
lBlockNo = wsSelect.Range("A1")
lRow = 1
' Find block with lBlockNo
For lBlock = 1 To lBlockNo
' Search the identifier string in current row
Do
lRow = lRow + 1
Set searchRange = wsSource.Rows(lRow)
Set bRange = searchRange.Find(strCellID, LookIn:=xlValues)
Loop While (bRange Is Nothing)
Next lBlock
lBlockRow = bRange.Row
lBlockCol = bRange.Column
' Search the first with empty cell
Do
lRow = lRow + 1
Loop While wsSource.Cells(lRow, lBlockCol) <> ""
' Copy the range found into the destination sheet
Range(Cells(lBlockRow, lBlockCol), Cells(lRow - 1, lBlockCol + 3)).Copy wsDest.Range("A1")
' Note the block copied
wsDest.Cells(1, 6) = "Block No:"
wsDest.Cells(1, 8) = lBlockNo
' Clean up (not absolutely necessary, but good practice)
Set searchRange = Nothing
Set bRange = Nothing
Set cRange = Nothing
Set wsSource = Nothing
Set wsDest = Nothing
Set wsSelect = Nothing
Set wb = Nothing
End Sub
Let me know if you need more help
I'm trying to create a macro in excel that takes cell values from one tab and creates a reference to these values as worksheets in vba.
An example of a worksheet list would be the following (could be longer or shorter in length):
sheet1
sheet2
sheet3
...
I have been able to store this in an array using the code below. With this array I would like to take these stored values and use them to reference worksheets as could be done manually as in the following.
ws1= wb.Sheets("sheet1")
ws(i)= wb.Sheets("ws(i)")
Any help to solve this or recommending a different approach would be greatly appreciated!
Thanks, M
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsInputsList As Worksheet
Set wsInputsList = wb.Sheets("InputsTab")
Dim lastrowInputs As Long
lastrowInputs = wsInputsList.Cells(Rows.Count, 1).End(xlUp).Row
Dim i As Integer
i = 1
Do While i < lastrowInputs
Dim ws(1 To 50) As Variant
ws(i) = wsInputsList.Cells(i + 1, 1).Value
i = i + 1
Loop
Tim Williams gave you the answer
Here I give you some more suggestions
code 1
Option Explicit
Sub SetSheetList()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsInputsList As Worksheet: Set wsInputsList = wb.Sheets("InputsTab")
Dim lastrowInputs As Long, i As Long
lastrowInputs = wsInputsList.Cells(Rows.Count, 1).End(xlUp).Row
ReDim ws(1 To lastrowInputs) As Worksheet 'dim your array only once
For i = 1 To lastrowInputs
Set ws(i) = wb.Sheets(wsInputsList.Cells(i, 1).Value)
Next
End Sub
where
moved array dimming outside the loop so as not to dim it lastrowInputs times…
used a For … Next loop which fist more your case (does what you need, does it clearly and in less stataments)
but this kind of sheets listing is prone to some drawbacks, like having a name in the list that is no more actual. For which case you could consider
Code 2
Option Explicit
Sub SetSheetList2()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsInputsList As Worksheet: Set wsInputsList = wb.Sheets("InputsTab")
Dim shtName As String
Dim lastrowInputs As Long, i As Long, nshts As Long
lastrowInputs = wsInputsList.Cells(Rows.Count, 1).End(xlUp).Row
ReDim ws(1 To lastrowInputs) As Worksheet 'dim your array only once
For i = 1 To lastrowInputs
shtName = wsInputsList.Cells(i, 1).Value ' store current "possible" sheet name
If IsSheetThere(wb, shtName) Then ' if current "possible" sheet name is an "actual" one
nshts = nshts + 1 ' update sheet names found
Set ws(nshts) = wb.Sheets(shtName) ' update sheets array
End If
Next
If nshts < lastrowInputs Then ReDim Preserve ws(1 To nshts) As Worksheet 'redim your array to the actual number of items stored, if needed
End Sub
And yet ther's a chance your sheet names list in "InputsTab" isn't exhaustive…
As you see, keeping and using such a list can be much more difficult than it might seem at the beginning: it's a matter of focusing on what you really need and why
I already have a filter macro that cleanses the data of the first sheet("RO") of the workbook, now i want to clean the second worksheet ("RSSI"), i thought that by declaring the second sheet as the actual worksheet might work but it still works on the first sheet.
Dim wsToFilter As Worksheet
Dim wbToFilter As Workbook
Set wbToFilter = Workbooks("2. Detalle_Transacciones_pendientes_rechazadas_MDM_27Ene20.xlsx")
Set wsToFilter = wbToFilter.Worksheets("Rechazos_SSI_2019")
Dim RowToTest2 As Long
For RowToTest2 = Cells(Rows.Count, 2).End(xlUp).row To 2 Step -1
With Cells(RowToTest2, 1)
If .Value <> "BATCH" _
Then _
Rows(RowToTest2).EntireRow.Delete
End With
Next RowToTest2
The code below first looks at one worksheet, then at another. I thought that's what you wanted. It retains your method of determining the rows to delete.
Dim wbToFilter As Workbook
Dim wsToFilter As Worksheet
Dim RowToTest2 As Long
Dim WsCounter As Integer
Set wbToFilter = Workbooks("2. Detalle_Transacciones_pendientes_rechazadas_MDM_27Ene20.xlsx")
' here the first worksheet is assigned to the variable WsToFilter
Set wsToFilter = wbToFilter.Worksheets("Rechazos_SSI_2019")
For WsCounter = 1 To 2
With wsToFilter ' all the following is executed on WsToFilter
' observe the leading periods which create the link
For RowToTest2 = .Cells(.Rows.Count, 2).End(xlUp).Row To 2 Step -1
With .Cells(RowToTest2, 1)
If .Value <> "BATCH" Then _
Rows(RowToTest2).EntireRow.Delete
End With
Next RowToTest2
End With
' now, for the second loop, the other worksheet is assigned
' to the variable WsToFilter
Set wsToFilter = wbToFilter.Worksheets("Rechazos_RO_2019")
Next WsCounter
Dim wsToFilter As Worksheet
Dim wbToFilter As Workbook
Set wbToFilter = Workbooks("2. Detalle_Transacciones_pendientes_rechazadas_MDM_27Ene20.xlsx")
Set wsToFilter = wbToFilter.Worksheets("Rechazos_SSI_2019")
With wsToFilter
.Range("A1").AutoFilter 1, "<>Batch"
.AutoFilter.Range.Offset(1).EntireRow.Delete
.AutoFilterMode = False
End With
Changed it into autofilter and worked perfectly, i took what Variatus wrote as a hint, so i modified my code like this.
I found code similar to the following where the data from one workbook is moved to another by using a loop. The code works except for the information that it moves is incorrect. Could someone tell me why it keeps copying the last column X number of times (where X = number of rows)? I want to copy the data between A2 and J11 only once instead of X rows of J2 and X rows of J3, and so on.
Sub CopySample()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lCol As Range, lRow As Range
Dim CurCell_1 As Range, CurCell_2 As Range
Application.ScreenUpdating = False
'~~> Change as applicable
Set wb1 = Workbooks("Sample1.xlsm")
Set wb2 = Workbooks("OverallData_Month_X.xlsm")
Set ws1 = wb1.Sheets("SampleSheet")
Set ws2 = wb2.Sheets("All Cylinders Data") '<~~ Change as required
For Each lCol In ws1.Range("A2:J11")
'~~> Why this?
Set CurCell_2 = ws2.Range("A2:J2")
For Each lRow In ws1.Range("A2:J11")
Set CurCell_1 = ws1.Cells(lRow.Row, lCol.Column)
If Not IsEmpty(CurCell_1) Then
CurCell_2.Value = CurCell_1.Value
Set CurCell_2 = CurCell_2.Offset(1)
End If
Next
Next
Application.ScreenUpdating = True
End Sub
Untested, but try changing this line Set CurCell_2 = ws2.Range("A2:J2") to :
Set CurCell_2 = ws2.Cells(1, lCol.Column)
UPDATE
Overall it seems that the above code is setting it's references to different sections of the workbook, and offsetting (moving) those references. I'd argue that there are more efficant ways to do this, and easier ways to code it as well. so while the above answer only solved half of the problems you were having, i've rewritten your code below so that it'll hopefully make more sence to you for you to understand + update.
I believe the below code example does what you're trying to accomplish:
(comments in code)
Sub CopySample
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Set wb1 = Workbooks("Sample1.xlsm")
Set wb2 = Workbooks("OverallData_Month_X.xlsm")
Set ws1 = wb1.Sheets("SampleSheet")
Set ws2 = wb2.Sheets("All Cylinders Data")
Dim rngCopyFromRange As Range
Set rngCopyFromRange = ws1.Range("A2:J11") '- name the copy range for ease of read
Dim rngPasteStartCell As Range
Set rngPasteStartCell = ws2.Range("A2") 'top left cellt o begin the paste
Dim lCurrentColumn As Long
Dim lCurrentRow As Long
For lCurrentColumn = 1 To rngCopyFromRange.Columns.Count 'for each column in the source data
For lCurrentRow = 1 To rngCopyFromRange.Rows.Count '-for each row in each column in source data
'set the offset of the starting cell's value equal ot the top left cell in the source data offset by the same amount
'- where the offsets are equal to the row/column we are on - 1
rngPasteStartCell.Offset(lCurrentRow - 1, lCurrentColumn - 1).Value = _
rngCopyFromRange.Cells(1, 1).Offset(lCurrentRow - 1, lCurrentColumn - 1).Value
Next lCurrentRow
Next lCurrentColumn
End Sub