Apparently, I'm trying to get the values from column b on excel and display each value in separate sheets..starting from sheet5. However, the code below seems to start from index 13 instead of the designated index 10. On my sheet5 it shows value 113, Sheet6 it shows 114...How can I solve this?
Sub InvoiceForm()
Dim wks As Worksheet
Dim i As Long
Dim ws As Worksheet
Set ws = ActiveSheet
Dim buffer As Long
buffer = ws.Range("B29").Value 'Getting the number of rows exist for column b'
Dim a As Long
a = 10
For Each wks In ThisWorkbook.Worksheets
For i = 5 To (i + buffer - 1)
If (a <= buffer + a - 1 And wks.CodeName = "Sheet" & i) Then
With wks
.Range("J2") = ws.Range("B" & a).Value
End With
a = a + 1
End If
Next i
Next wks
End Sub
Related
I have this vba code that appends/distributes records from a Data mastersheet to individual named sheets. This is done based on column E's value. It works fine but ends in an error whenever it encounters a value on column E that's not one of the sheets in the file. Can you please help me so as to allow it to just skip those records and proceed with the processing? Thanks!
Sub CopyDataToSheets()
Dim copyfromws As Worksheet
Dim copytows As Worksheet
Dim cfrng As Range
Dim ctrng As Range
Dim cflr As Long
Dim ctlr As Long
Dim i As Long
Dim currval As String
Set copyfromws = Sheets("Data")
cflr = copyfromws.Cells(Rows.Count, "B").End(xlUp).Row
' Copy Row of Data to Specific Worksheet based on value in Column E
' Existing Formulas in Columns F through H or J are automatically extended to the new row of data
For i = 2 To cflr
currval = copyfromws.Cells(i, 1).Value
Set copytows = Sheets(currval)
ctlr = copytows.Cells(Rows.Count, "B").End(xlUp).Row + 1
Set cfrng = copyfromws.Range("A" & i & ":N" & i)
Set ctrng = copytows.Range("A" & ctlr & ":N" & ctlr)
ctrng.Value = cfrng.Value
Next
End Sub
I would make a small helper function that can test if the worksheet exists. That way you can control the logic of your loop.
Function SheetExists(sheetName As String, Optional wb As Workbook) As Boolean
If wb Is Nothing Then Set wb = ThisWorkbook
Dim ws As Worksheet
On Error Resume Next
Set ws = wb.Sheets(sheetName)
SheetExists = Err = 0
End Function
Im trying to copy and paste my data and assign them into different worksheets.For example, if column F is martin 1, the entire row that has martin1 will be paste to worksheets("Index1"). Same thing for Charlie 1 and it will be paste to worksheets("Index2"). However, I faced with a object defined error here as shown in my code below. Any ideas how to solve it?
Sub SaveRangewithConsecutiveDuplicateValuestoNewSheet()
'Define all variables
Dim wb As Workbook, ws As Worksheet, sCel As Range, rwNbr As Long
Set wb = ThisWorkbook 'Set workbook variable
Set ws = wb.Worksheets("Sheet1") 'set worksheet variable using workbook variable
Set sCel = ws.Cells(1, 6) 'Set the first start cell variable to test for duplicate values
Dim i As Integer
Dim site_i As Worksheet
For i = 1 To 3
Set site_i = Sheets.Add(after:=Sheets(Worksheets.count))
site_i.Name = "Index" & CStr(i)
Next i
Application.DisplayAlerts = False
For rwNbr = 2 To ws.Cells(ws.Rows.count, 6).End(xlUp).Offset(1).Row Step 1 'Loop
If ws.Cells(rwNbr, 6).Value = "Martin1" Then
ws.Range(sCel, ws.Cells(rwNbr, 6)).EntireRow.Copy Destination:=Sheets("Index1").Range("A1")
ElseIf ws.Cells(rwNbr, 6).Value = "Charlie1" Then
ws.Range(sCel, ws.Cells(rwNbr - ws.UsedRange.Rows.count, 6)).EntireRow.CopyDestination:=Sheets("Index2").Range("A1") '<----application defined or object defined error here
End If
Next rwNbr
Application.DisplayAlerts = True
End Sub
This is the link to my worksheet. https://www.dropbox.com/home?preview=Sample+-+Copy.xlsm
The final output should look something like this...
If your raw data does not have a header row then I would use a loop to gather up your target cells and copy them accordingly.
You will need to update your 3 target values inside Arr to Charlie1, Martin1, etc.
Macro Steps
Loop through each name in Arr
Loop through each row in Sheet1
Add target row to a Union (collection of cells)
Copy the Union to the target sheet where target Sheet Index # = Arr position + 1
Sub Filt()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim cs As Worksheet
Dim Arr: Arr = Array("Value1", "Value2", "Value3")
Dim x As Long, Target As Long, i As Long
Dim CopyMe As Range
'Create 3 Sheets, move them to the end, rename
For x = 1 To 3
Set cs = ThisWorkbook.Sheets.Add(After:=Sheets(ThisWorkbook.Sheets.Count))
cs.Name = "Index" & x
Next x
lr = ws.Range("F" & ws.Rows.Count).End(xlUp).Row
'Loop through each name in array
For Target = LBound(Arr) To UBound(Arr)
'Loop through each row
For i = 1 To lr
'Create Union of target rows
If ws.Range("F" & i) = Arr(Target) Then
If Not CopyMe Is Nothing Then
Set CopyMe = Union(CopyMe, ws.Range("F" & i))
Else
Set CopyMe = ws.Range("F" & i)
End If
End If
Next i
'Copy the Union to Target Sheet
If Not CopyMe Is Nothing Then
CopyMe.EntireRow.Copy Destination:=ThisWorkbook.Sheets("Index" & Target + 1).Range("A1")
Set CopyMe = Nothing
End If
Next Target
End Sub
Tested and working as expected on my end, however....
If you had headers this would be much easier with a copy/paste. If you run the same macro on same book twice this will break for many reasons such as having duplicated sheet names, breaking the relationship between Sheet Index # = Arr Position + 1, etc...
I want to delete entire row if value in column B (sheet "Track") is the same as value in column B (sheet "Active").
But run time error 13 (type mismatch) always occur even though both values I refer are string type
Here is the code:
Sub delete_row()
Dim active As Worksheet: Set activeSH = ThisWorkbook.Sheets("Active")
Dim Tracksheet As Worksheet: Set KPI = ThisWorkbook.Sheets("Track")
Dim i As Integer
Dim name As String
With Tracksheet
For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 4 Step -1
name = .Range("B" & i).Value
'Here I loop through each value in col B of Track sheet
'and reference it to values in col B of sheet "active"
If name = active.Range("B:B").Value Then 'this line where run time error 13 (type mismatch occurs)
.Rows(i).EntireRow.Delete
Else
End If
i = i - 1
Next i
End With
End Sub
I really appreciate your help!
You might wanna try something like this:
Sub delete_row()
Dim active As Worksheet
Dim Tracksheet As Worksheet
Dim i As Integer
Dim name As String
Dim cl As Range
Set active = ThisWorkbook.Sheets("Active")
Set Tracksheet = ThisWorkbook.Sheets("Track")
With Tracksheet
For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 4 Step -1
name = .Range("B" & i).Value
For Each cl In active.Range("B1:B100")
If name = cl.Value Then
.Rows(i).EntireRow.Delete
End If
Next cl
i = i - 1
Next i
End With
End Sub
You can change the Range B1:B100 as per your requirement.
My code is working when I just use a single workbook and communicate between sheets but gives me subscript out of range errors and object not defined errors when I attempt to reference a cell range in a sheet contained in a different work book. Right now, the error is occurring at "Set pidat = Worksheets("pidat")
Dim pival As Double
'Dim eom As Worksheet 'declaring pidat worksheet as variable
'Set eom = Worksheets("EOM") 'declaring eom worksheet as variable
'Set Inv_Level = Worksheets("Inv_Levels")
Dim pidat As Worksheet 'declaring eom worksheet as variable
Set pidat = Worksheets("pidat")
Dim steve As Workbook
Set steve = Application.Workbooks("EOM Report VBA")
Dim EOMAs As Workbook
Set EOMAs = Application.Workbooks("EOMA")
Dim Inv_Level As Worksheet
'These changes allow for a dynamic range to be referenced outside of the active sheet/workbook
Dim location As String
Dim rownum As Long
Dim loopy As Long
Dim fRng As Range
Dim J As Long
Dim rn As Date
Dim last As Date
Dim rnm As Integer
Dim lastm As Integer
Dim tyear As Long
Dim K As Long
With pidat
J = .Range("J2").Value
rn = Now
last = .Range("B1").Value
rnm = month(rn)
lastm = month(last)
tyear = year(rn)
If lastm < rnm Then
.Range("B1") = (rnm & "/" & "01" & "/" & tyear & " 07:30")
J = J + 100
.Range("J2") = J
End If
End With
K = J + 100
'names of workbook/sheet referenced
With steve
rownum = .Range("E" & Rows.Count).End(xlUp).Row 'counts the number of rows in the location tag column
For loopy = 3 To rownum 'Data values start after row 3, loops through each row in the column
If .Range("E" & loopy) <> "" Then
location = .Range("E" & loopy)
'newloc = location
With Inv_Level
Set fRng = .Cells.Range("A" & J, "ZZ" & K).Find(What:=location, LookIn:=xlFormulas, LookAt:=xlPart) 'eom can be any sheet you need to perform the .Find again
End With
If Not fRng Is Nothing Then
fRng.Offset(0, -1) = pidat.Range("D" & loopy)
Else: End If
'if the search item is not found, do nothing, go to next loop
End If
Next loopy
End With
End Sub
You need to qualify the specific workbook you want to work with.
The line Set pidat = Worksheets("pidat") will fail if the active workbook at the time this line is executed has no worksheet named pidat.
Here is an example of how to qualify a workbook
Dim theWorkbook as Workbook
Set theWorkbook = Application.Workbooks("myWorkbook")
Dim pidat as Worksheet
Set pidat = theWorkbook.Worksheets("pidat")
You could go one step further and verify that a sheet named pidat (or whatever) exists in the qualified workbook, but I'll leave you to discover how to do that :)
I would like to export data from a consolidated sheet (DATA) to multiple sheets regarding criteria.
I have a total of 13 criteria, each criteria has to be exported in its dedicated sheet.
I'm trying to optimize this macro (only 2 criteria here) because it lag out
Sub copy()
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")
For Each sh In ThisWorkbook.Worksheets
If sh.Name = "S01" Then
i = 2
j = 2
While Not IsEmpty(feuillePrincipale.Cells(i, 1))
If feuillePrincipale.Cells(i, 11).Value Like "S01*" Then
feuillePrincipale.Cells.Rows(i).EntireRow.copy S01Sheet.Rows(j)
j = j + 1
End If
i = i + 1
Wend
End If
If sh.Name = "S02" Then
i = 2
j = 2
While Not IsEmpty(feuillePrincipale.Cells(i, 1))
If feuillePrincipale.Cells(i, 11).Value Like "S02*" Then
feuillePrincipale.Cells.Rows(i).EntireRow.copy S02Sheet.Rows(j)
j = j + 1
End If
i = i + 1
Wend
End If
Next
Application.ScreenUpdating = True
End Sub
If you have any idea, I read I can use Advanced filter but as you guess I'm new in VBA so I'm listening any tips!
Here is the Advanced Filter method you asked for:
Public Sub Christophe()
Const FILTER_COLUMN = 11
Dim i&, rCrit As Range, rData As Range, aShts
aShts = ["SO"&row(1:13)]
Set rData = Sheets("DATA").[a1].CurrentRegion
Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
rCrit(1) = rData(1, FILTER_COLUMN)
For i = 1 To UBound(aShts)
rCrit(2) = aShts(i, 1) & "*"
rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i, 1)).[a1].Resize(, rData.Columns.Count)
Next
rCrit.Clear
End Sub
The execution time should be instantaneous.
Note: this assumes that you do have 13 criteria, each starting with "SO" and that they occupy column 11 of the Data sheet. It also assumes that you already have 13 sheets named SO1... SO13 in the workbook.
UPDATE
Based on new information that the pattern of the criteria can change, please try this version instead. Note, that it assumes that the sheets already exist and that the sheet names match the criteria:
Public Sub Christophe()
Const FILTER_COLUMN = 11
Dim i&, rCrit As Range, rData As Range, aShts
aShts = Array("SO1", "SO2", "ADQ03", "LocS10")
Set rData = Sheets("DATA").[a1].CurrentRegion
Set rCrit = rData.Resize(2, 1).Offset(, rData.Columns.Count + 2)
rCrit(1) = rData(1, FILTER_COLUMN)
For i = 0 To UBound(aShts)
rCrit(2) = aShts(i) & "*"
rData.AdvancedFilter xlFilterCopy, rCrit, Sheets(aShts(i)).[a1].Resize(, rData.Columns.Count)
Next
rCrit.Clear
End Sub
Try using an array to set your criteria sheets:
Dim shArray As Variant
Dim shArrayString As String
Dim feuillePrincipale As Excel.Worksheet
Dim i As Long
Dim j As Long
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
j = 1
'// Create array and populate
shArray = Array("S01", "S02", "S03", "S04") '// add as required
'// Create string representation of array
shArrayString = "{"""
For i = LBound(shArray) To UBound(shArray)
shArrayString = shArrayString & shArray(i) & ""","""
Next
shArrayString = Left(shArrayString, Len(shArrayString) - 2) & "}"
'//Start loop
With feuillePrincipale
For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If Not Evaluate("ISERROR(MATCH(" & Left(.Cells(i, 11), 3) & "," & shArrayString & ",0))") Then
.Rows(i).Copy Sheets(shArray(WorksheetFunction.Match(Left(.Cells(i, 11), 3), shArray, 0))).Cells(j, 1)
j = j + 1
End If
Next
End With
It's a bit unclear because if you follow the code you've posted - it's actually just copying and pasting data to the same sheet...
Yes, you should use an autofilter and use a special select to get only the visible cells.
If you want the loop method, you should loop through each row on sheets("DATA") and use a Select Case Statement to decide onto which sheet the data is placed.
By looping through each sheet you are adding loops that will slow it down.
Application.ScreenUpdating = False
Dim i As Long
Dim j As Long
Dim cel As Range
Dim sh As Worksheet
Dim feuillePrincipale As Worksheet
Dim S01Sheet As Worksheet
Dim S02Sheet As Worksheet
Set feuillePrincipale = ThisWorkbook.Sheets("DATA")
Set S01Sheet = ThisWorkbook.Sheets("S01")
Set S02Sheet = ThisWorkbook.Sheets("S02")
For Each cel In feuillePrincipale.Range(feuillePrincipale.Range("A1"), feuillePrincipale.Range("A1").End(xlDown))
Select Case Left(cel.offset(,10).value, 3)
Case "S01"
j = S01Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S01Sheet.Rows(j)
Case "S02"
j = S02Sheet.Range("A" & Rows.count).End(xlUp).Offset(1).Row
feuillePrincipale.Cells.Rows(cel.Row).EntireRow.copy S02Sheet.Rows(j)
'Case .... keep adding select statement till you get to the last condition
Case Else
End Select
Next cel
Application.ScreenUpdating = True