I'm trying to run this code but only for specific worksheet names. the name is as follows "X_Score_" & CurrentDate where CurrentDate changes every time the loop runs. Right now it runs for all worksheets in the whole workbook which is quite messy.
Set wsMaster = ThisWorkbook.Worksheets("XXX_SCORE_TOTAL")
RowTracker = 2
flag = False
For Each bs In ActiveWorkbook.Worksheets
If UCase(bs.Name) <> "XXX_SCORE_TOTAL" Then
LastRow = bs.Cells(Rows.Count, "A").End(xlUp).Row
LastColumn = bs.Cells(1, Columns.Count).End(xlToLeft).Column
End If
bs.Range(bs.Cells(2, 1), bs.Cells(LastRow, LastColumn)).Copy wsMaster.Cells(RowTracker, 1)
RowTracker = RowTracker + LastRow
Next bs
I tried to predifine something like Set MyCollection = ThisWorkbook.Worksheets("X_Score_" & CurrentDate) and then put in in the For loop like For Each bs In MyCollectionbut it didn't worked
If the goal is to process all sheets in the workbook whose names start with "X_Score_", this can be done with Left():
Sub test1()
Set wsMaster = ThisWorkbook.Worksheets("XXX_SCORE_TOTAL")
RowTracker = 2
flag = False
For Each bs In ThisWorkbook.Worksheets ' or ActiveWorkbook?
If Left(UCase(bs.Name), 8) = "X_SCORE_" Then
LastRow = bs.Cells(Rows.Count, "A").End(xlUp).Row
LastColumn = bs.Cells(1, Columns.Count).End(xlToLeft).Column
Set Rng = bs.Range(bs.Cells(2, 1), bs.Cells(LastRow, LastColumn))
Rng.Copy wsMaster.Cells(RowTracker, 1)
RowTracker = RowTracker + Rng.Rows.Count ' shift RowTracker according to the number of rows copied
End If
Next
End Sub
Related
I have a macro that I use in Excel 2010 to loop through some xls files, extracting the data from each into a xlsm file. There should be about 195,000 rows from across all of the xls files, but after running it I end up with closer to 90,000. If I run it on only a few of the files at once I get the correct number so it seems to be something to do with the volume I'm trying to incorporate, but I understand that an xlsm can handle up to a million rows so that shouldn't be a problem, should it?. I've split the source files into batches in the past but I'd rather avoid doing that if possible. Ultimately, I'm trying to compile a csv to import into a SQL database. If anybody has any suggestions, I'd be very grateful.
Thanks.
PS I've asked about this before a month or so ago but as I'd totally misdiagnosed the issue and was asking about the wrong thing, I'm writing a fresh question so that I don't set people off on the wrong track. I was rightly chastised for not including enough code last time. This is the subroutine which extracts the data:
Sub import_data()
Dim wk As Workbook
Dim shRead As Worksheet, ws As Worksheet
Dim i As Integer
Dim reportLocation As String
Dim report As String
Dim reportList As String
Dim reportArray() As String
Dim shReadLastColumn As Long
Dim shReadLastRow As Long
'generate list of xls to open
reportLocation = "C:\Foo"
report = Dir(reportLocation & "\*.xls")
reportList = ""
Do While Len(report) > 0
reportList = report & "," & reportList
report = Dir
Loop
reportArray() = Split(reportList, ",")
'loop through list of xls files
For i = UBound(reportArray) To LBound(reportArray) Step -1
If reportArray(i) <> "" Then
Set wk = Workbooks.Open(reportLocation & "\" & reportArray(i), ReadOnly:=True)
Set shRead = wk.Worksheets(1)
With shRead
shReadLastColumn = .Cells(10, shRead.Columns.count).End(xlToLeft).Column
shReadLastRow = .Cells(shRead.Rows.count, "A").End(xlUp).Row
End With
'copy list over on to xlsm compilation
Dim target_row As Long
Set ws = ThisWorkbook.Worksheets(1)
If IsEmpty(ws.Cells(1, 1)) Then
target_row = 1
shRead.Range(shRead.Cells(10, 1), shRead.Cells(shReadLastRow, shReadLastColumn)).Copy ws.Cells(target_row, 1)
Else
target_row = ws.Cells(Rows.count, 1).End(xlUp).Row + 1
shRead.Range(shRead.Cells(10 + 1, 1), shRead.Cells(shReadLastRow, shReadLastColumn)).Copy ws.Cells(target_row, 1)
End If
wk.Activate
ActiveWorkbook.Close False
End If
Set wk = Nothing
Set shRead = Nothing
Next i
End Sub
Thanks for any help!
You appear to have an unqualified reference with missing workbook object for target_row:
target_row = ws.Cells(Rows.count, 1).End(xlUp).Row + 1
which should be
target_row = ws.Cells(ws.Rows.count, 1).End(xlUp).Row + 1
Also, consider using a With block and avoid any Activate or ActiveWorkbook calls:
' WITH BLOCK (no use of ws)
With ThisWorkbook.Worksheets(1)
If IsEmpty(.Cells(1, 1)) Then
target_row = 1
shRead.Range(shRead.Cells(10, 1), shRead.Cells(shReadLastRow, shReadLastColumn)).Copy .Cells(target_row, 1)
Else
target_row = .Cells(.Rows.count, 1).End(xlUp).Row + 1
shRead.Range(shRead.Cells(10 + 1, 1), shRead.Cells(shReadLastRow, shReadLastColumn)).Copy .Cells(target_row, 1)
End If
End With
' ADJUSTED LINE
wk.Close False
Also, if you only need data without formats, consider range assignment:
With ThisWorkbook.Worksheets(1)
...
target_row = .Cells(.Rows.count, 1).End(xlUp).Row + 1
.Cells(target_row, target_row + shReadLastRow - 11).Value = shRead.Range( _
shRead.Cells(10 + 1, 1), shRead.Cells(shReadLastRow, shReadLastColumn) _
)
...
End With
a bit of an odd one. I have a file with large amount of info that goes up to column "CH". Information in the workbook is spread through multiple tabs and when I consolidate data it copies everything except for the last column. Wonder if you could help me with that
Sub consolidation()
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Sheets("Consolidation").Delete
Application.DisplayAlerts = True
With ActiveWorkbook
Set Destination = .Sheets.Add(After:=.Sheets(.Sheets.Count))
Destination.Name = "Consolidation"
End With
Dim i As Integer
Dim stOne As Worksheet
Dim stOneLastRow As Long
Dim stTwo As Worksheet
Dim stTwoLastRow As Long
Dim consolid As Worksheet
Dim consolidLastRow As Long
Set stOne = ThisWorkbook.Sheets("Sheet1")
Set stTwo = ThisWorkbook.Sheets("Sheet2")
Set consolid = ThisWorkbook.Sheets("Consolidation")
stOneLastRow = stOne.Range("C" & Rows.Count).End(xlUp).Row
stTwoLastRow = stTwo.Range("C" & Rows.Count).End(xlUp).Row
consolidLastRow = consolid.Range("C" & Rows.Count).End(xlUp).Row
For i = 6 To stOneLastRow
stOne.Select
If stOne.Range("C6").Value = "OM ID" Then
Cells(i, 3).Resize(1, 100).Copy
consolid.Select
NextRow = Cells(Rows.Count, 2).End(xlUp).Row + 1
Cells(NextRow, 2).Select
ActiveSheet.Paste
stOne.Select
End If
Next i
For i = 7 To stTwoLastRow
stTwo.Select
If stTwo.Range("C6").Value = "OM ID" Then
Cells(i, 3).Resize(1, 100).Copy
consolid.Select
NextRow = Cells(Rows.Count, 2).End(xlUp).Row + 1
Cells(NextRow, 2).Select
ActiveSheet.Paste
stTwo.Select
End If
Next i
End Sub
Initial code is taken from here: https://learn.microsoft.com/en-us/office/vba/api/excel.range.copy
Tried to copy rows based on the value in CH cell, but still copies everything except for that column...
Very weird :-(
Omg... I feel so stupid. The data starts from 3rd column, but I copied everything starting from the 2nd colum... macro works correctly, just needed to change the column...
I have 2 columns on a sheet "list", one column that lists all business entities, the other lists all org units. The functionality of the code below works perfectly but returns an error because it exceeds the sheet row limit.
The data is pasted onto a sheet "cc_act" is there a way to at point of error create a new sheet called "cc_act1"...."cc_act2" until the script is complete?
Declare Function HypMenuVRefresh Lib "HsAddin" () As Long
Sub cc()
Application.ScreenUpdating = False
Dim list As Worksheet: Set list = ThisWorkbook.Worksheets("list")
Dim p As Worksheet: Set p = ThisWorkbook.Worksheets("p")
Dim calc As Worksheet: Set calc = ThisWorkbook.Worksheets("calc")
Dim cc As Worksheet: Set cc = ThisWorkbook.Worksheets("cc_act")
Dim cc_lr As Long
Dim calc_lr As Long: calc_lr = calc.Cells(Rows.Count, "A").End(xlUp).Row
Dim calc_lc As Long: calc_lc = calc.Cells(1,
calc.Columns.Count).End(xlToLeft).Column
Dim calc_rg As Range
Dim ctry_rg As Range
Dim i As Integer
Dim x As Integer
list.Activate
For x = 2 To Range("B" & Rows.Count).End(xlUp).Row
If list.Range("B" & x).Value <> "" Then
p.Cells(17, 3) = list.Range("B" & x).Value
End If
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
If list.Range("A" & i).Value <> "" Then
p.Cells(17, 4) = list.Range("A" & i).Value
p.Calculate
End If
p.Activate
Call HypMenuVRefresh
p.Calculate
'''changes country on calc table
calc.Cells(2, 2) = p.Cells(17, 4)
calc.Cells(2, 3) = p.Cells(17, 3)
calc.Calculate
'''copy the calc range and past under last column
With calc
Set calc_rg = calc.Range("A2:F2" & calc_lr)
End With
With cc
cc_lr = cc.Cells(Rows.Count, "A").End(xlUp).Row + 1
calc_rg.Copy
cc.Cells(cc_lr, "A").PasteSpecial xlPasteValues
End With
Next i
Next x
Application.ScreenUpdating = True
End Sub
I suppose there are a few ways to handle something like this. See the code sample below, and adapt it to your specific needs.
Sub LongColumnToAFewColumns()
Dim wsF As Worksheet, WST As Worksheet
Dim rf As Range, rT As Range
Dim R As Long, j As Integer
' initialize
Set wsF = ActiveSheet
Set WST = Sheets.Add
WST.Name = "Results"
j = 1
For R = 1 To wsF.Cells(Rows.Count, 1).End(xlUp).Row Step 65536
wsF.Cells(R, 1).Resize(65536).Copy
WST.Cells(j, 1).PasteSpecial xlPasteValues
WST.Cells(j, 1).PasteSpecial xlPasteValues
j = j + 1
Next R
End Sub
As an aside, you may want to consider using MS Access for this kind of thing. Or, better yet, Python or even R. Good luck with your project.
could you help me out with this problem in my vba code ? (I was trying to go through many topics about 1004 error on forums, yet I am a vba novice and was not able to deal with it..).
there is Table in RaWData sheet with headers - I need to clean the data part, then in next section I am going to copy there some of the data from other sheet where is Pivot table
Error on the line (section 'Sheet RawData cleaning):
RawData.Range(Cells(2, 1), Cells(LastRow, LastCol)).Delete
Not whole code but here is a bit:
'Exporting
Dim FZ As Workbook
Dim Cesta As Variant
Dim i As Long
Dim SubRegion As String
Dim rTable As Range
Dim CurrDate As String
Dim RawData As Worksheet
Dim SFDCReport As Worksheet
Dim MS As Worksheet
Dim DS As Worksheet
Dim DealOffice As Worksheet
Set DS = ThisWorkbook.Sheets("Data")
Set MS = ThisWorkbook.Sheets("Macro")
Cesta = Application.GetOpenFilename
Set FZ = Workbooks.Open(Filename:=Cesta, Local:=True)
Set RawData = FZ.Sheets("RawData")
Set SFDCReport = FZ.Sheets("SFDC Report")
Set DealOffice = FZ.Sheets("Coverage DealOffice")
CurrDate = MS.Range("E1").Value
For i = 1 To PRFilter
'Check if Export column is not empty for each SubRegion, if yes, skip to next Subregion(Iteration)
If IsEmpty(MS.Cells(i + 1, 2).Value) Then
GoTo NextIteration
Else 'Things to do if "Not Empty"
'SubRegion value paste into C10 so Highlights section is updated
SubRegion = MS.Cells(i + 1, 1).Value
SFDCReport.Cells(10, 3).Value = SubRegion
'Sheet SFDC Report Cleaning
With SFDCReport
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(12, .Columns.Count).End(xlToLeft).Column
.Range(Cells(14, 1), Cells(LastRow, LastCol)).Delete
End With
'Filter, Select & Copy filtered data to SFDCReport table
DS.Range("A1").CurrentRegion.AutoFilter Field:=84, Criteria1:=SubRegion
Set rTable = DS.AutoFilter.Range
Set rTable = rTable.Resize(rTable.Rows.Count - 1)
Set rTable = rTable.Offset(1) 'Move new range down to start at the first data row
rTable.Copy
SFDCReport.Cells(13, 1).PasteSpecial xlPasteValues
DealOffice.PivotTables("PivotTable1").RefreshTable 'Refresh PivotTable on DealOffice Sheet
'Sheet RawData Cleaning
LastCol = RawData.UsedRange.Columns.Count
LastRow = RawData.UsedRange.Rows.Count
RawData.Range(Cells(2, 1), Cells(LastRow, LastCol)).Delete
'Sheet CoverageDealOffice Pivot data copying to RawData
With DealOffice
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastCol = .Cells(17, .Columns.Count).End(xlToLeft).Column
.Range(Cells(17, 1), Cells(LastRow - 1, LastCol)).Copy
End With
RawData.Cells(2, 1).PasteSpecial xlPasteValues
'Formatting/other changes & Saving
SFDCReport.Activate
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
ActiveWindow.ScrollColumn = 68
DealOffice.Select
FZ.SaveAs Filename:=DirExport & "\" & CurrDate & "_NCE Deal Office Report_" & SubRegion & ".xlsb", FileFormat:=50
NextIteration:
End If
Next
Thanks guys, Gamca
not sure why this keeps copying whole data set from original to the destination.. I need only filtered data to be copied into Destination, that begins with A13 in the destination sheet SFDCReport
'Filter, Select & Copy filtered data to SFDCReport table
DS.Range("A1").CurrentRegion.AutoFilter Field:=84, Criteria1:=SubRegion
LastRow = DS.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
LastCol = DS.AutoFilter.Range.Columns.Count
Set rTable = DS.AutoFilter.Range
Set rTable = rTable.Resize(rTable.Rows.Count - 1)
Set rTable = rTable.Offset(1) 'Move new range down to start at the first data row
Set rTable2 = SFDCReport.Range(SFDCReport.Cells(13, 1), SFDCReport.Cells(LastRow, LastCol))
rTable2.Value = rTable.Value
Corrected/Solved - Thanks to some advices, I have changed the "syntax" coding to use With/End With + paid attention to include "address" into all Range objects.
part of changed code:
'Filter, Select & Copy filtered data to SFDCReport table
With DS.Range("A1").CurrentRegion
.AutoFilter Field:=84, Criteria1:=SubRegion
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy SFDCReport.Cells(13, 1)
End With
I pasted the entire macro below but this is the important part.
Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value
Range("D2:D10000").Value = Range("D2").Offset(-1, 1).Value
Range("F2:F10000").Value = Range("F2").Offset(-1, 1).Value
Range("H2:H10000").Value = Range("H2").Offset(-1, 1).Value
It works as is except it is creating unnecessary data because I don't know how to use variable names in a range object. My ranges are currently hard coded such as ("A1:A1000"), when I would like it to be something like ("A1:A & LastRow).
Also I have to explicitly call out column names to copy because the range won't accept a variable name like ("currentColumn & 1:currentColumn & LastRow).
Is there a way to use a varible name as part of a range object so we can use them in loops?
Sub prepareWorkbook()
Dim wbk As Workbook
Set wbk = ThisWorkbook
Dim wks As Worksheet
Set wks = wbk.ActiveSheet
Dim colx As Long
Dim ColumnCount As Long
Dim MySheetName As String
MySheetName = "Import"
LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
ActiveSheet.Name = MySheetName
'identify the Id column and move it to 1st column
Dim answer As Variant
Dim IdColumn As Range
answer = Application.InputBox("Enter Letter of Id column")
If Columns(answer).Column = 1 Then
Else
'cut Id column from current location and insert it at column index 1
Columns(answer).Select
Selection.Cut
Columns("A:A").Select
Selection.Insert Shift:=xlToRight
End If
'trim the PartNumber column of any trailing spaces
Dim c As Range
For Each c In Range("A1:A10000")
c.Value = Application.Trim(Replace(c.Value, Chr(160), Chr(32)))
Next
' insert column every other column
' Loop through number of columns.
ColumnCount = Application.WorksheetFunction.CountA(Rows(1)) * 2
'step 2 means skip every other
For colx = 2 To ColumnCount Step 2
Columns(colx).Insert Shift:=xlToRight
Next
Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value
Range("D2:D10000").Value = Range("D2").Offset(-1, 1).Value
Range("F2:F10000").Value = Range("F2").Offset(-1, 1).Value
Range("H2:H10000").Value = Range("H2").Offset(-1, 1).Value
wks.Cells.EntireColumn.AutoFit
MsgBox ("Done")
End Sub
Assuming the you are running code in the Worksheet added here:
'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
ActiveSheet.Name = MySheetName
Also not sure what is the purpose of this code, nevertheless using it for the sample
Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value
Try this:
Dim lLastRow As Long
lLastRow = wbk.Worksheets(MySheetName).UsedRange.SpecialCells(xlLastCell).Row
Rem This updates only columns B, D, F & H - adjust as needed
For colx = 2 To 8 Step 2
With wbk.Worksheets(MySheetName)
Rem Creates Range as Range(Cells(rIni,cIini), Cells(rEnd,cEnd))
rem Corresponding code for "Range("B2:B10000").Value = Range("B2").Offset(-1, 1).Value" (see comment above)
Range(.Cells(2, colx), .Cells(lLastRow, colx)) = .Cells(2, colx).Offset(-1, 1).Value
End With: Next
Something like:
Dim LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Range("B2:B" & LastRow).Value = Range("B2").Offset(-1, 1).Value
Range("D2:D" & LastRow).Value = Range("D2").Offset(-1, 1).Value
Range("F2:F" & LastRow).Value = Range("F2").Offset(-1, 1).Value
Range("H2:H" & LastRow).Value = Range("H2").Offset(-1, 1).Value
Although this answer won't be applied to your situation, I feel like this could help answer some questions you have in there.
When specifying a range, you can separate the column (letter) and row (number) and use your own variables.
In a for loop, this could look like
for i = 1 to 100
Range("A" & i).Value = Range("A"&i).Offset(, 1).Value
next
You can also determine the number of the row of the selected cell using:
dim RowNb as long
RowNb = (ActiveCell.Row)
This also applies to columns, and can be used in a loop like I mentionned at the start.
The one thing that was conspicuous by its absence in your description was any mention of the nature of the data in the worksheet. You mentioned A1 briefly but your range value assignments started at row 2 so it may be inferred that row 1 contains column header labels.
Sub prepareWorkbook()
Dim wbk As Workbook, wks As Worksheet
Dim colx As Long
Dim lc As Long, lr As Long
Dim MySheetName As String
Set wbk = ThisWorkbook 'no idea what this does
Set wks = wbk.ActiveSheet 'no idea what this does
MySheetName = "Import"
'no idea what this does or what sht is
'LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
'copy the worksheet and rename it before editing
Sheets(1).Copy After:=Sheets(1)
With Sheets(2)
.Name = MySheetName
If CBool(Application.CountIf(.Rows(1), "PartNumber")) Then
colx = Application.Match("PartNumber", .Rows(1), 0)
Else
colx = .Range(Application.InputBox("Enter Letter of Id column") & 1).Column
End If
If .Columns(colx).Column > 1 Then
'cut Id column from current location and insert it at column index 1
.Columns(colx).Cut
.Columns(1).Insert Shift:=xlToRight
End If
'quickest way to trim trailing spaces is with Text-to-Columns, Fixed Width
With .Columns(1)
.TextToColumns Destination:=.Cells(1), DataType:=xlFixedWidth, FieldInfo:=Array(0, 1)
End With
' insert column every other column (working backwards toward A1)
For lc = .Cells(1, Columns.Count).End(xlToLeft).Column To 2 Step -1
.Columns(lc).Insert Shift:=xlToRight
Next lc
For lc = (.Cells(1, Columns.Count).End(xlToLeft).Column - 1) To 2 Step -2
'let's put the row-by-row value in instead of a single value into all cells
lr = .Cells(Rows.Count, lc + 1).End(xlUp).Row
With .Cells(2, lc).Resize(lr - 1, 1)
.Cells = .Offset(-1, 1).Value
.EntireColumn.AutoFit
End With
Next lc
End With
Set wbk = Nothing
Set wks = Nothing
End Sub
Explanations as comments in code.